- DGPMV331 ;ALB/MIR - ASIH DISCHARGE PROCESSING ; 11 JAN 89 @9
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ASIH ;if admission type was TO ASIH...
- Q:'$D(^DGPM(+$P(DGPMAN,"^",21),0)) S DGPMAI=$P(^(0),"^",14),DGPMAA=$S($D(^DGPM(+DGPMAI,0)):^(0),1:"")
- D DEL:($P(DGPMA,"^",18)=41),CRXFR:($P(DGPMA,"^",18)=46) G Q:("^41^46^"[("^"_$P(DGPMA,"^",18)_"^"))
- Q:+DGPMP=+DGPMA
- S DA=$S($D(^DGPM(+$P(DGPMAA,"^",17),0)):$P(DGPMAA,"^",17),1:"") I $D(^DGPM(+DA,0)),($P(^(0),"^",18)=47) G Q
- 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
- S DIE="^DGPM(",DA=DGPMDA,DR=".22////"_1 K DQ,DG D ^DIE
- 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
- Q K DGPMAA,DGPMAI,DGPMXMT Q
- DEL ;delete the NHCU discharge if FROM ASIH - called from transfer, too
- S DA=$S($D(^DGPM(+$P(DGPMAA,"^",17),0)):$P(DGPMAA,"^",17),1:"")
- I $D(^DGPM(+DA,0)) D
- . S ^UTILITY("DGPM",$J,1,DGPMAI,"P")=DGPMAA
- . 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
- . S ^UTILITY("DGPM",$J,1,DGPMAI,"A")=$G(^DGPM(DGPMAI,0))
- 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]""
- Q:DGPMT=2 ;quit if coming from xfr routine (returning from ASIH (O.F.)
- CRXFR ;for FROM ASIH and CONTINUED ASIH (O.F.), create corresponding transfer
- 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
- S DIE="^DGPM(",DR=".22////"_1,DA=DGPMDA K DQ,DG D ^DIE ;set sequence number for hospital discharge
- S DIE("NO^")="",X=+DGPMA,DGPM0ND=+DGPMA_"^"_2_"^"_DFN_"^"_DGX_"^^^^^^^^^^"_DGPMAI_"^^^^^^^^"_2 D NEW^DGPMV3
- S ^UTILITY("DGPM",$J,2,+Y,"P")="",^UTILITY("DGPM",$J,2,+Y,"A")=$G(^DGPM(+Y,0))
- S DGX=$S($P(DGPMA,"^",18)=41:14,1:45)
- 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
- 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
- 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:"")
- K DQ,DG D ^DIE I $P(^DGPM(DA,0),"^",5) S ^UTILITY("DGPM",$J,2,DA,"A")=^DGPM(DA,0) D SPEC Q
- UNDO ;delete discharge/transfer is time-out during transfer
- S DGPMER=1 W !!,*7,*7,"Time-out during ASIH movement...now deleting discharge and transfer"
- S DIK="^DGPM(" F DA=DGPMDA,DGPMXMT D ^DIK S ^UTILITY("DGPM",$J,$S(DA=DGPMDA:3,1:2),"A")=""
- 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
- Q
- SPEC ;ask specialty on return?
- S Y=DGPMXMT I $D(^DG(405.1,+DGHX,0)),$P(^(0),"^",5) D SPEC^DGPMV36
- K DGHX
- Q
- DGPMV331 ;ALB/MIR - ASIH DISCHARGE PROCESSING ; 11 JAN 89 @9
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ASIH ;if admission type was TO ASIH...
- +1 IF '$DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0))
- QUIT
- SET DGPMAI=$PIECE(^(0),"^",14)
- SET DGPMAA=$SELECT($DATA(^DGPM(+DGPMAI,0)):^(0),1:"")
- +2 IF ($PIECE(DGPMA,"^",18)=41)
- DO DEL
- IF ($PIECE(DGPMA,"^",18)=46)
- DO CRXFR
- IF ("^41^46^"[("^"_$PIECE(DGPMA,"^",18)_"^"))
- GOTO Q
- +3 IF +DGPMP=+DGPMA
- QUIT
- +4 SET DA=$SELECT($DATA(^DGPM(+$PIECE(DGPMAA,"^",17),0)):$PIECE(DGPMAA,"^",17),1:"")
- IF $DATA(^DGPM(+DA,0))
- IF ($PIECE(^(0),"^",18)=47)
- GOTO Q
- +5 ;update NHCU/DOM discharge
- IF $DATA(^DGPM(+DA,0))
- SET ^UTILITY("DGPM",$JOB,3,DA,"P")=$SELECT($DATA(^UTILITY("DGPM",$JOB,3,DA,"P")):^("P"),1:^DGPM(DA,0))
- SET DR=".01///"_+DGPMA_";.22////"_2
- SET DIE="^DGPM("
- KILL DQ,DG
- DO ^DIE
- SET ^UTILITY("DGPM",$JOB,3,DA,"A")=^DGPM(DA,0)
- +6 SET DIE="^DGPM("
- SET DA=DGPMDA
- SET DR=".22////"_1
- KILL DQ,DG
- DO ^DIE
- +7 ;update NHCU/DOM PTF discharge date
- SET DA=$PIECE(DGPMAA,"^",16)
- IF $DATA(^DGPT(+DA,0))
- SET DIE="^DGPT("
- SET DR="70////"_+DGPMA
- KILL DQ,DG
- DO ^DIE
- Q KILL DGPMAA,DGPMAI,DGPMXMT
- QUIT
- DEL ;delete the NHCU discharge if FROM ASIH - called from transfer, too
- +1 SET DA=$SELECT($DATA(^DGPM(+$PIECE(DGPMAA,"^",17),0)):$PIECE(DGPMAA,"^",17),1:"")
- +2 IF $DATA(^DGPM(+DA,0))
- Begin DoDot:1
- +3 SET ^UTILITY("DGPM",$JOB,1,DGPMAI,"P")=DGPMAA
- +4 ;Delete ASIH discharge
- SET ^UTILITY("DGPM",$JOB,3,DA,"P")=$SELECT($DATA(^UTILITY("DGPM",$JOB,3,DA,"P")):^("P"),1:^DGPM(DA,0))
- SET ^("A")=""
- SET DIK="^DGPM("
- DO ^DIK
- +5 SET ^UTILITY("DGPM",$JOB,1,DGPMAI,"A")=$GET(^DGPM(DGPMAI,0))
- End DoDot:1
- +6 SET DA=$SELECT($DATA(^DGPT(+$PIECE(DGPMAA,"^",16),0)):$PIECE(DGPMAA,"^",16),1:"")
- IF DA
- SET DR="70///@;71///@;72///@"
- SET DIE="^DGPT("
- KILL DQ,DG
- IF DR]""
- DO ^DIE
- +7 ;quit if coming from xfr routine (returning from ASIH (O.F.)
- IF DGPMT=2
- QUIT
- CRXFR ;for FROM ASIH and CONTINUED ASIH (O.F.), create corresponding transfer
- +1 ;get active mvt type for from asih or continued asih (of) transfer
- SET DGMAS=$SELECT($PIECE(DGPMA,"^",18)=41:14,1:45)
- DO FAMT^DGPMV30
- SET (DGX,DGHX)=DGFAC
- KILL DGFAC
- +2 ;set sequence number for hospital discharge
- SET DIE="^DGPM("
- SET DR=".22////"_1
- SET DA=DGPMDA
- KILL DQ,DG
- DO ^DIE
- +3 SET DIE("NO^")=""
- SET X=+DGPMA
- SET DGPM0ND=+DGPMA_"^"_2_"^"_DFN_"^"_DGX_"^^^^^^^^^^"_DGPMAI_"^^^^^^^^"_2
- DO NEW^DGPMV3
- +4 SET ^UTILITY("DGPM",$JOB,2,+Y,"P")=""
- SET ^UTILITY("DGPM",$JOB,2,+Y,"A")=$GET(^DGPM(+Y,0))
- +5 SET DGX=$SELECT($PIECE(DGPMA,"^",18)=41:14,1:45)
- +6 SET DIE="^DGPM("
- SET (DA,DGPMXMT)=+Y
- SET DR=$SELECT(DGX=45:".05",1:".06;.07")
- SET DIE("NO^")=""
- IF DGX=14
- KILL DQ,DG
- DO ^DIE
- IF '$PIECE(^DGPM(DA,0),"^",6)
- GOTO UNDO
- SET ^UTILITY("DGPM",$JOB,2,DA,"A")=^DGPM(DA,0)
- DO SPEC
- QUIT
- +7 SET X=0
- FOR I=+DGPMAN:0
- SET I=$ORDER(^DGPM("APMV",DFN,DGPMAI,I))
- IF 'I
- QUIT
- SET J=$ORDER(^(I,0))
- IF $DATA(^DGPM(+J,0))
- IF ("^13^43^"[("^"_$PIECE(^(0),"^",18)_"^"))
- SET X=^(0)
- QUIT
- +8 IF X
- SET I=$ORDER(^DGPM("APMV",DFN,DGPMAI,I))
- SET J=$ORDER(^(+I,0))
- IF $DATA(^DGPM(+J,0))
- SET X=^(0)
- SET DR=DR_$SELECT($PIECE(X,"^",6):";.06////"_$PIECE(X,"^",6),1:"")_$SELECT($PIECE(X,"^",7):";.07////"_$PIECE(X,"^",7),1:"")
- +9 KILL DQ,DG
- DO ^DIE
- IF $PIECE(^DGPM(DA,0),"^",5)
- SET ^UTILITY("DGPM",$JOB,2,DA,"A")=^DGPM(DA,0)
- DO SPEC
- QUIT
- UNDO ;delete discharge/transfer is time-out during transfer
- +1 SET DGPMER=1
- WRITE !!,*7,*7,"Time-out during ASIH movement...now deleting discharge and transfer"
- +2 SET DIK="^DGPM("
- FOR DA=DGPMDA,DGPMXMT
- DO ^DIK
- SET ^UTILITY("DGPM",$JOB,$SELECT(DA=DGPMDA:3,1:2),"A")=""
- +3 IF $PIECE(DGPMA,"^",18)=41
- DO SET^DGPMV32
- IF '$DATA(^DGPM(+$PIECE(DGPMAN,"^",21),0))
- QUIT
- NEW DGPMCA,DGPMAN
- SET DGPMCA=$PIECE(^(0),"^",14)
- SET DGPMAN=$SELECT($DATA(^DGPM(DGPMCA,0)):^(0),1:"")
- DO ASIHOF^DGPMV321
- +4 QUIT
- SPEC ;ask specialty on return?
- +1 SET Y=DGPMXMT
- IF $DATA(^DG(405.1,+DGHX,0))
- IF $PIECE(^(0),"^",5)
- DO SPEC^DGPMV36
- +2 KILL DGHX
- +3 QUIT
