| 1 | DGPMV331 ;ALB/MIR - ASIH DISCHARGE PROCESSING ; 11 JAN 89 @9
|
|---|
| 2 | ;;5.3;Registration;;Aug 13, 1993
|
|---|
| 3 | ASIH ;if admission type was TO ASIH...
|
|---|
| 4 | Q:'$D(^DGPM(+$P(DGPMAN,"^",21),0)) S DGPMAI=$P(^(0),"^",14),DGPMAA=$S($D(^DGPM(+DGPMAI,0)):^(0),1:"")
|
|---|
| 5 | D DEL:($P(DGPMA,"^",18)=41),CRXFR:($P(DGPMA,"^",18)=46) G Q:("^41^46^"[("^"_$P(DGPMA,"^",18)_"^"))
|
|---|
| 6 | Q:+DGPMP=+DGPMA
|
|---|
| 7 | S DA=$S($D(^DGPM(+$P(DGPMAA,"^",17),0)):$P(DGPMAA,"^",17),1:"") I $D(^DGPM(+DA,0)),($P(^(0),"^",18)=47) G Q
|
|---|
| 8 | I $D(^DGPM(+DA,0)) S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)),DR=".01///"_+DGPMA_";.22////"_2,DIE="^DGPM(" K DQ,DG D ^DIE S ^UTILITY("DGPM",$J,3,DA,"A")=^DGPM(DA,0) ;update NHCU/DOM discharge
|
|---|
| 9 | S DIE="^DGPM(",DA=DGPMDA,DR=".22////"_1 K DQ,DG D ^DIE
|
|---|
| 10 | S DA=$P(DGPMAA,"^",16) I $D(^DGPT(+DA,0)) S DIE="^DGPT(",DR="70////"_+DGPMA K DQ,DG D ^DIE ;update NHCU/DOM PTF discharge date
|
|---|
| 11 | Q K DGPMAA,DGPMAI,DGPMXMT Q
|
|---|
| 12 | DEL ;delete the NHCU discharge if FROM ASIH - called from transfer, too
|
|---|
| 13 | S DA=$S($D(^DGPM(+$P(DGPMAA,"^",17),0)):$P(DGPMAA,"^",17),1:"")
|
|---|
| 14 | I $D(^DGPM(+DA,0)) D
|
|---|
| 15 | . S ^UTILITY("DGPM",$J,1,DGPMAI,"P")=DGPMAA
|
|---|
| 16 | . S ^UTILITY("DGPM",$J,3,DA,"P")=$S($D(^UTILITY("DGPM",$J,3,DA,"P")):^("P"),1:^DGPM(DA,0)),^("A")="",DIK="^DGPM(" D ^DIK ;Delete ASIH discharge
|
|---|
| 17 | . S ^UTILITY("DGPM",$J,1,DGPMAI,"A")=$G(^DGPM(DGPMAI,0))
|
|---|
| 18 | S DA=$S($D(^DGPT(+$P(DGPMAA,"^",16),0)):$P(DGPMAA,"^",16),1:"") I DA S DR="70///@;71///@;72///@",DIE="^DGPT(" K DQ,DG D ^DIE:DR]""
|
|---|
| 19 | Q:DGPMT=2 ;quit if coming from xfr routine (returning from ASIH (O.F.)
|
|---|
| 20 | CRXFR ;for FROM ASIH and CONTINUED ASIH (O.F.), create corresponding transfer
|
|---|
| 21 | S DGMAS=$S($P(DGPMA,"^",18)=41:14,1:45) D FAMT^DGPMV30 S (DGX,DGHX)=DGFAC K DGFAC ;get active mvt type for from asih or continued asih (of) transfer
|
|---|
| 22 | S DIE="^DGPM(",DR=".22////"_1,DA=DGPMDA K DQ,DG D ^DIE ;set sequence number for hospital discharge
|
|---|
| 23 | S DIE("NO^")="",X=+DGPMA,DGPM0ND=+DGPMA_"^"_2_"^"_DFN_"^"_DGX_"^^^^^^^^^^"_DGPMAI_"^^^^^^^^"_2 D NEW^DGPMV3
|
|---|
| 24 | S ^UTILITY("DGPM",$J,2,+Y,"P")="",^UTILITY("DGPM",$J,2,+Y,"A")=$G(^DGPM(+Y,0))
|
|---|
| 25 | S DGX=$S($P(DGPMA,"^",18)=41:14,1:45)
|
|---|
| 26 | S DIE="^DGPM(",(DA,DGPMXMT)=+Y,DR=$S(DGX=45:".05",1:".06;.07"),DIE("NO^")="" I DGX=14 K DQ,DG D ^DIE G:'$P(^DGPM(DA,0),"^",6) UNDO S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0) D SPEC Q
|
|---|
| 27 | S X=0 F I=+DGPMAN:0 S I=$O(^DGPM("APMV",DFN,DGPMAI,I)) Q:'I S J=$O(^(I,0)) I $D(^DGPM(+J,0)),("^13^43^"[("^"_$P(^(0),"^",18)_"^")) S X=^(0) Q
|
|---|
| 28 | I X S I=$O(^DGPM("APMV",DFN,DGPMAI,I)),J=$O(^(+I,0)) I $D(^DGPM(+J,0)) S X=^(0),DR=DR_$S($P(X,"^",6):";.06////"_$P(X,"^",6),1:"")_$S($P(X,"^",7):";.07////"_$P(X,"^",7),1:"")
|
|---|
| 29 | K DQ,DG D ^DIE I $P(^DGPM(DA,0),"^",5) S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0) D SPEC Q
|
|---|
| 30 | UNDO ;delete discharge/transfer is time-out during transfer
|
|---|
| 31 | S DGPMER=1 W !!,*7,*7,"Time-out during ASIH movement...now deleting discharge and transfer"
|
|---|
| 32 | S DIK="^DGPM(" F DA=DGPMDA,DGPMXMT D ^DIK S ^UTILITY("DGPM",$J,$S(DA=DGPMDA:3,1:2),"A")=""
|
|---|
| 33 | I $P(DGPMA,"^",18)=41 D SET^DGPMV32 Q:'$D(^DGPM(+$P(DGPMAN,"^",21),0)) N DGPMCA,DGPMAN S DGPMCA=$P(^(0),"^",14),DGPMAN=$S($D(^DGPM(DGPMCA,0)):^(0),1:"") D ASIHOF^DGPMV321
|
|---|
| 34 | Q
|
|---|
| 35 | SPEC ;ask specialty on return?
|
|---|
| 36 | S Y=DGPMXMT I $D(^DG(405.1,+DGHX,0)),$P(^(0),"^",5) D SPEC^DGPMV36
|
|---|
| 37 | K DGHX
|
|---|
| 38 | Q
|
|---|
