- PSGOTR ;BIR/CML3-TRANSFERS RENEW DATA FROM 53.1 TO 55 ;23 SEP 03 / 7:54 AM
- ;;5.0; INPATIENT MEDICATIONS ;**110,127,133,129**;16 DEC 97
- ;
- ; Reference to ^PS(55 supported by DBIA 2191.
- ;
- START(ODA,DA) ; lock record, and write
- N OFD,PVND4 S OFD=""
- S OFD=$P($G(^PS(55,PSGP,5,DA,2)),"^",4) K:OFD ^PS(55,"AUD",+OFD,PSGP,+DA)
- S ND2=^PS(53.1,+ODA,2) S ^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)=""
- F X=6,7 I $D(^PS(53.1,+ODA,X)) S ^PS(55,PSGP,5,DA,X)=^(X)
- I $O(^PS(53.1,+ODA,1,0)) D
- .K ^PS(55,PSGP,5,DA,1)
- .S (C,X)=0 F S X=$O(^PS(53.1,+ODA,1,X)) Q:'X S:$D(^(X,0)) C=C+1,^PS(55,PSGP,5,DA,1,C,0)=^(0),^PS(55,PSGP,5,DA,1,"B",+$P($G(^(0)),U),C)=""
- .S ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
- F X=3,12 D S ^PS(55,PSGP,5,DA,X,0)="^55.0"_$S(X=3:8,1:612)_U_CNT_U_CNT
- .S CNT=0 F C=0:0 S C=$O(^PS(53.1,+ODA,X,C)) Q:'C I $D(^(C,0)) S ^PS(55,PSGP,5,DA,X,C,0)=^(0),CNT=CNT+1
- S $P(^PS(53.1,+ODA,0),"^",19)=DA
- S $P(^PS(55,PSGP,5,DA,0),"^",7)=$P(^PS(53.1,+ODA,0),"^",7)
- N PSGPND0,PSGPND2,RDUZ,OND14 S PSGPND0=^PS(53.1,+ODA,0),PSGPND2=^(2) S RNWDT=$P(PSGPND0,"^",16),PSGOEPR=$P(PSGPND0,"^",2)
- S PSGFD=$P(PSGPND2,"^",4),PSJNOO=$P(^PS(53.1,+ODA,.2),"^",3) S OND14=$$LASTREN^PSJLMPRI(PSGP,+ODA_"P") S RDUZ=$P(OND14,"^",2) S:$P(OND14,"^",3) PSGOEPR=$P(OND14,"^",3)
- I '$G(DUOUT) D
- .I $G(PSJORD)["P" N PSGFDO S PSGFDO=$$LASTREN^PSJLMPRI(PSGP,PSJORD),PSGFDO=$P(PSGFDO,"^",4)
- .D UPDREN^PSGOER(DA_"U",RNWDT,PSGOEPR,$S($G(PSGFDO):PSGFDO,1:PSGFD),PSJNOO,RDUZ)
- S PVND4=$G(^PS(53.1,+ODA,4)) I $P(PVND4,"^"),$P(PVND4,"^",2) D
- .N RNDT S RNDT=$$LASTREN^PSJLMPRI(DFN,+ODA_"P") Q:RNDT>$P(PVND4,"^",2)
- .S $P(^PS(55,DFN,5,DA,4),"^")=$P(PVND4,"^"),$P(^PS(55,DFN,5,DA,4),"^",2)=$P(PVND4,"^",2)
- CR ; set x-refs
- I $D(^PS(55,PSGP,5.1)),$P(^(5.1),"^",6) S X=$P(^(5.1),"^",6) I $P(ND2,"^",3),$P(ND2,"^",6)'>X S $P(^(5.1),"^",6)=$P(ND2,"^",3)
- S ^PS(55,PSGP,5,"B",+ODA,DA)="",^PS(55,"AUE",PSGP,DA)=""
- F S="C","O","P","R","OC" K ^PS(55,PSGP,5,"AU",S,+$P(PSGPND2,"^",4),DA)
- S ^PS(55,PSGP,5,"AU",$P(PSGPND0,"^",7),+$P(PSGPND2,"^",4),DA)=""
- S ^PS(55,PSGP,5,"AUS",+$P(ND2,"^",4),DA)="" I OFD,OFD'=$P(ND2,"^",4) K ^PS(55,PSGP,5,"AUS",+OFD,DA)
- I $$PATCH^XPDUTL("PXRM*1.5*12") S X(1)=+$P(ND2,"^",2),X(2)=+$P(ND2,"^",4),DA(1)=PSGP D SPSPA^PSJXRFS(.X,.DA,"UD")
- K DIK S DA(1)=PSGP S DIK="^PS(55,"_DA(1)_",5,",DIK(1)=125 D EN1^DIK K DIK
- S PSGTOL=2,PSGTOO=1 F PSGUOW=0:0 S PSGUOW=$O(^PS(53.41,2,1,PSGUOW)) Q:'PSGUOW I $D(^(PSGUOW,1,PSGP,1,2,1,+ODA)) K ^(+ODA) D ENL^PSGVDS
- DONE I $D(PSGOE2),PSGOE2]"",$D(^TMP("PSJON",$J,PSGOE2)) S ^(PSGOE2)=DA_"U"
- S PSGODA=ODA,PSGORD=DA_"U"
- F Q=0:0 S Q=$O(^PS(53.44,Q)) Q:'Q I $D(^(Q,1,PSGP,+ODA,0)) S $P(^(0),"^",2)=DA
- L -^PS(53.1,ODA) L -^PS(55,DFN,5,+PSGORD) K CNT,ND,ODA,XX,ZND Q
- PSGOTR ;BIR/CML3-TRANSFERS RENEW DATA FROM 53.1 TO 55 ;23 SEP 03 / 7:54 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**110,127,133,129**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(55 supported by DBIA 2191.
- +4 ;
- START(ODA,DA) ; lock record, and write
- +1 NEW OFD,PVND4
- SET OFD=""
- +2 SET OFD=$PIECE($GET(^PS(55,PSGP,5,DA,2)),"^",4)
- IF OFD
- KILL ^PS(55,"AUD",+OFD,PSGP,+DA)
- +3 SET ND2=^PS(53.1,+ODA,2)
- SET ^PS(55,"AUD",+$PIECE(ND2,"^",4),PSGP,DA)=""
- +4 FOR X=6,7
- IF $DATA(^PS(53.1,+ODA,X))
- SET ^PS(55,PSGP,5,DA,X)=^(X)
- +5 IF $ORDER(^PS(53.1,+ODA,1,0))
- Begin DoDot:1
- +6 KILL ^PS(55,PSGP,5,DA,1)
- +7 SET (C,X)=0
- FOR
- SET X=$ORDER(^PS(53.1,+ODA,1,X))
- IF 'X
- QUIT
- IF $DATA(^(X,0))
- SET C=C+1
- SET ^PS(55,PSGP,5,DA,1,C,0)=^(0)
- SET ^PS(55,PSGP,5,DA,1,"B",+$PIECE($GET(^(0)),U),C)=""
- +8 SET ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
- End DoDot:1
- +9 FOR X=3,12
- Begin DoDot:1
- +10 SET CNT=0
- FOR C=0:0
- SET C=$ORDER(^PS(53.1,+ODA,X,C))
- IF 'C
- QUIT
- IF $DATA(^(C,0))
- SET ^PS(55,PSGP,5,DA,X,C,0)=^(0)
- SET CNT=CNT+1
- End DoDot:1
- SET ^PS(55,PSGP,5,DA,X,0)="^55.0"_$SELECT(X=3:8,1:612)_U_CNT_U_CNT
- +11 SET $PIECE(^PS(53.1,+ODA,0),"^",19)=DA
- +12 SET $PIECE(^PS(55,PSGP,5,DA,0),"^",7)=$PIECE(^PS(53.1,+ODA,0),"^",7)
- +13 NEW PSGPND0,PSGPND2,RDUZ,OND14
- SET PSGPND0=^PS(53.1,+ODA,0)
- SET PSGPND2=^(2)
- SET RNWDT=$PIECE(PSGPND0,"^",16)
- SET PSGOEPR=$PIECE(PSGPND0,"^",2)
- +14 SET PSGFD=$PIECE(PSGPND2,"^",4)
- SET PSJNOO=$PIECE(^PS(53.1,+ODA,.2),"^",3)
- SET OND14=$$LASTREN^PSJLMPRI(PSGP,+ODA_"P")
- SET RDUZ=$PIECE(OND14,"^",2)
- IF $PIECE(OND14,"^",3)
- SET PSGOEPR=$PIECE(OND14,"^",3)
- +15 IF '$GET(DUOUT)
- Begin DoDot:1
- +16 IF $GET(PSJORD)["P"
- NEW PSGFDO
- SET PSGFDO=$$LASTREN^PSJLMPRI(PSGP,PSJORD)
- SET PSGFDO=$PIECE(PSGFDO,"^",4)
- +17 DO UPDREN^PSGOER(DA_"U",RNWDT,PSGOEPR,$SELECT($GET(PSGFDO):PSGFDO,1:PSGFD),PSJNOO,RDUZ)
- End DoDot:1
- +18 SET PVND4=$GET(^PS(53.1,+ODA,4))
- IF $PIECE(PVND4,"^")
- IF $PIECE(PVND4,"^",2)
- Begin DoDot:1
- +19 NEW RNDT
- SET RNDT=$$LASTREN^PSJLMPRI(DFN,+ODA_"P")
- IF RNDT>$PIECE(PVND4,"^",2)
- QUIT
- +20 SET $PIECE(^PS(55,DFN,5,DA,4),"^")=$PIECE(PVND4,"^")
- SET $PIECE(^PS(55,DFN,5,DA,4),"^",2)=$PIECE(PVND4,"^",2)
- End DoDot:1
- CR ; set x-refs
- +1 IF $DATA(^PS(55,PSGP,5.1))
- IF $PIECE(^(5.1),"^",6)
- SET X=$PIECE(^(5.1),"^",6)
- IF $PIECE(ND2,"^",3)
- IF $PIECE(ND2,"^",6)'>X
- SET $PIECE(^(5.1),"^",6)=$PIECE(ND2,"^",3)
- +2 SET ^PS(55,PSGP,5,"B",+ODA,DA)=""
- SET ^PS(55,"AUE",PSGP,DA)=""
- +3 FOR S="C","O","P","R","OC"
- KILL ^PS(55,PSGP,5,"AU",S,+$PIECE(PSGPND2,"^",4),DA)
- +4 SET ^PS(55,PSGP,5,"AU",$PIECE(PSGPND0,"^",7),+$PIECE(PSGPND2,"^",4),DA)=""
- +5 SET ^PS(55,PSGP,5,"AUS",+$PIECE(ND2,"^",4),DA)=""
- IF OFD
- IF OFD'=$PIECE(ND2,"^",4)
- KILL ^PS(55,PSGP,5,"AUS",+OFD,DA)
- +6 IF $$PATCH^XPDUTL("PXRM*1.5*12")
- SET X(1)=+$PIECE(ND2,"^",2)
- SET X(2)=+$PIECE(ND2,"^",4)
- SET DA(1)=PSGP
- DO SPSPA^PSJXRFS(.X,.DA,"UD")
- +7 KILL DIK
- SET DA(1)=PSGP
- SET DIK="^PS(55,"_DA(1)_",5,"
- SET DIK(1)=125
- DO EN1^DIK
- KILL DIK
- +8 SET PSGTOL=2
- SET PSGTOO=1
- FOR PSGUOW=0:0
- SET PSGUOW=$ORDER(^PS(53.41,2,1,PSGUOW))
- IF 'PSGUOW
- QUIT
- IF $DATA(^(PSGUOW,1,PSGP,1,2,1,+ODA))
- KILL ^(+ODA)
- DO ENL^PSGVDS
- DONE IF $DATA(PSGOE2)
- IF PSGOE2]""
- IF $DATA(^TMP("PSJON",$JOB,PSGOE2))
- SET ^(PSGOE2)=DA_"U"
- +1 SET PSGODA=ODA
- SET PSGORD=DA_"U"
- +2 FOR Q=0:0
- SET Q=$ORDER(^PS(53.44,Q))
- IF 'Q
- QUIT
- IF $DATA(^(Q,1,PSGP,+ODA,0))
- SET $PIECE(^(0),"^",2)=DA
- +3 LOCK -^PS(53.1,ODA)
- LOCK -^PS(55,DFN,5,+PSGORD)
- KILL CNT,ND,ODA,XX,ZND
- QUIT
