PSGOT ;BIR/CML3-TRANSFERS DATA FROM 53.1 TO 55 ;24 SEP 97 / 7:54 AM
;;5.0; INPATIENT MEDICATIONS ;**13,68,90,110,173,134,161**;16 DEC 97;Build 28
;
; Reference to ^PS(55 supported by DBIA 2191.
; Reference to ^PSUHL supported by DBIA 4803.
;
START ; get internal record number, lock record, and write
S ODA=+PSGORD S:$D(^PS(55,PSGP,0))[0 ^(0)=PSGP,^PS(55,"B",PSGP,PSGP)="",$P(^PS(55,0),U,3,4)=PSGP_U_($P($G(^PS(55,0)),U,4)+1) F L +^PS(55,PSGP,5,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S ZND=$G(^PS(55,PSGP,5,0)) S:ZND="" ZND="^55.06IA" F DA=$P(ZND,"^",3)+1:1 I '$D(^PS(55,PSGP,5,DA)),'$D(^("B",DA)) L +^PS(55,PSGP,5,DA):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I S $P(ZND,"^",3)=DA,$P(ZND,"^",4)=$P(ZND,"^",4)+1,^PS(55,PSGP,5,0)=ZND Q
L -^PS(55,PSGP,5,0) S ND0=^PS(53.1,ODA,0),$P(ND0,"^",23)=PSJPWD,^PS(55,PSGP,5,DA,0)=ND0
S (ND1,^PS(55,PSGP,5,DA,.2))=$G(^PS(53.1,ODA,.2)),^PS(55,PSGP,5,DA,.3)=$G(^PS(53.1,ODA,.3)),(ND2,^PS(55,PSGP,5,DA,2))=^PS(53.1,ODA,2),^PS(55,PSGP,5,DA,4)=$G(^PS(53.1,ODA,4)),^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)=""
S X=^PS(55,PSGP,0) I $P(X,"^",7)="" S $P(X,"^",7)=$P($P(ND0,"^",16),"."),$P(X,"^",8)="A",^(0)=X D LOGDFN^PSUHL(PSGP)
I $P($G(^PS(55,PSGP,5,DA,2)),"^",6)="" S $P(^PS(55,PSGP,5,DA,2),"^",6)=$S($G(PSGS0XT)'="":PSGS0XT,$P($G(ZZND),"^",3)'="":$P(ZZND,"^",3),1:""),$P(^PS(53.1,ODA,2),"^",6)=$P(^PS(55,PSGP,5,DA,2),"^",6)
F X=6,7,13 I $D(^PS(53.1,ODA,X)) S ^PS(55,PSGP,5,DA,X)=^(X)
I $D(^PS(53.1,ODA,"DSS")) S ^PS(55,PSGP,5,DA,8)=^("DSS")
I $O(^PS(53.1,ODA,1,0)) 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)=""
I $O(^PS(53.1,ODA,1,0)) 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
CR ; set x-refs
N A
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,PSGP,5,"AU",$P(ND0,"^",7),+$P(ND2,"^",4),DA)=""
S ^PS(55,PSGP,5,"AUS",+$P(ND2,"^",4),DA)=""
S ^PS(55,PSGP,5,"C",+ND1,DA)="",^PS(55,"AUE",PSGP,DA)=""
S ^PS(55,"AUDS",+$P(ND2,"^",2),PSGP,DA)=""
I $D(^PS(55,PSGP,5,DA,8)) S A=^(8),^PS(55,"AUDC",+$P(ND2,"^",4),+A,PSGP,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"
S PSGNODE=$G(^PS(55,PSGP,5,DA,0)),PSG25=$P(PSGNODE,"^",25),PSG26=$P(PSGNODE,"^",26)
I PSG25 S X=$S(PSG25["V":"^PS(55,"_PSGP_",""IV"",",PSG25["U"!(PSG25["A"):"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSG25_","_$E("02",PSG25["V"+1)_")" I $D(@X) S $P(@X,"^",$S(PSG25["V":6,1:26))=DA_"U"
I $P(PSGNODE,"^",26),$P(PSGNODE,"^",26)'["V",$D(^PS(55,PSGP,5,+$P(PSGNODE,"^",26),0)) S $P(^(0),"^",25)=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
PSGOT ;BIR/CML3-TRANSFERS DATA FROM 53.1 TO 55 ;24 SEP 97 / 7:54 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**13,68,90,110,173,134,161**;16 DEC 97;Build 28
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA 2191.
+4 ; Reference to ^PSUHL supported by DBIA 4803.
+5 ;
START ; get internal record number, lock record, and write
+1 SET ODA=+PSGORD
IF $DATA(^PS(55,PSGP,0))[0
SET ^(0)=PSGP
SET ^PS(55,"B",PSGP,PSGP)=""
SET $PIECE(^PS(55,0),U,3,4)=PSGP_U_($PIECE($GET(^PS(55,0)),U,4)+1)
FOR
LOCK +^PS(55,PSGP,5,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+2 SET ZND=$GET(^PS(55,PSGP,5,0))
IF ZND=""
SET ZND="^55.06IA"
FOR DA=$PIECE(ZND,"^",3)+1:1
IF '$DATA(^PS(55,PSGP,5,DA))
IF '$DATA(^("B",DA))
LOCK +^PS(55,PSGP,5,DA):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
SET $PIECE(ZND,"^",3)=DA
SET $PIECE(ZND,"^",4)=$PIECE(ZND,"^",4)+1
SET ^PS(55,PSGP,5,0)=ZND
QUIT
+3 LOCK -^PS(55,PSGP,5,0)
SET ND0=^PS(53.1,ODA,0)
SET $PIECE(ND0,"^",23)=PSJPWD
SET ^PS(55,PSGP,5,DA,0)=ND0
+4 SET (ND1,^PS(55,PSGP,5,DA,.2))=$GET(^PS(53.1,ODA,.2))
SET ^PS(55,PSGP,5,DA,.3)=$GET(^PS(53.1,ODA,.3))
SET (ND2,^PS(55,PSGP,5,DA,2))=^PS(53.1,ODA,2)
SET ^PS(55,PSGP,5,DA,4)=$GET(^PS(53.1,ODA,4))
SET ^PS(55,"AUD",+$PIECE(ND2,"^",4),PSGP,DA)=""
+5 SET X=^PS(55,PSGP,0)
IF $PIECE(X,"^",7)=""
SET $PIECE(X,"^",7)=$PIECE($PIECE(ND0,"^",16),".")
SET $PIECE(X,"^",8)="A"
SET ^(0)=X
DO LOGDFN^PSUHL(PSGP)
+6 IF $PIECE($GET(^PS(55,PSGP,5,DA,2)),"^",6)=""
SET $PIECE(^PS(55,PSGP,5,DA,2),"^",6)=$SELECT($GET(PSGS0XT)'="":PSGS0XT,$PIECE($GET(ZZND),"^",3)'="":$PIECE(ZZND,"^",3),1:"")
SET $PIECE(^PS(53.1,ODA,2),"^",6)=$PIECE(^PS(55,PSGP,5,DA,2),"^",6)
+7 FOR X=6,7,13
IF $DATA(^PS(53.1,ODA,X))
SET ^PS(55,PSGP,5,DA,X)=^(X)
+8 IF $DATA(^PS(53.1,ODA,"DSS"))
SET ^PS(55,PSGP,5,DA,8)=^("DSS")
+9 IF $ORDER(^PS(53.1,ODA,1,0))
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)=""
+10 IF $ORDER(^PS(53.1,ODA,1,0))
SET ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
+11 FOR X=3,12
Begin DoDot:1
+12 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
+13 SET $PIECE(^PS(53.1,ODA,0),"^",19)=DA
CR ; set x-refs
+1 NEW A
+2 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)
+3 SET ^PS(55,PSGP,5,"B",+ODA,DA)=""
SET ^PS(55,PSGP,5,"AU",$PIECE(ND0,"^",7),+$PIECE(ND2,"^",4),DA)=""
+4 SET ^PS(55,PSGP,5,"AUS",+$PIECE(ND2,"^",4),DA)=""
+5 SET ^PS(55,PSGP,5,"C",+ND1,DA)=""
SET ^PS(55,"AUE",PSGP,DA)=""
+6 SET ^PS(55,"AUDS",+$PIECE(ND2,"^",2),PSGP,DA)=""
+7 IF $DATA(^PS(55,PSGP,5,DA,8))
SET A=^(8)
SET ^PS(55,"AUDC",+$PIECE(ND2,"^",4),+A,PSGP,DA)=""
+8 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")
+9 KILL DIK
SET DA(1)=PSGP
SET DIK="^PS(55,"_DA(1)_",5,"
SET DIK(1)=125
DO EN1^DIK
KILL DIK
+10 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 SET PSGNODE=$GET(^PS(55,PSGP,5,DA,0))
SET PSG25=$PIECE(PSGNODE,"^",25)
SET PSG26=$PIECE(PSGNODE,"^",26)
+3 IF PSG25
SET X=$SELECT(PSG25["V":"^PS(55,"_PSGP_",""IV"",",PSG25["U"!(PSG25["A"):"^PS(55,"_PSGP_",5,",1:"^PS(53.1,")_+PSG25_","_$EXTRACT("02",PSG25["V"+1)_")"
IF $DATA(@X)
SET $PIECE(@X,"^",$SELECT(PSG25["V":6,1:26))=DA_"U"
+4 IF $PIECE(PSGNODE,"^",26)
IF $PIECE(PSGNODE,"^",26)'["V"
IF $DATA(^PS(55,PSGP,5,+$PIECE(PSGNODE,"^",26),0))
SET $PIECE(^(0),"^",25)=DA_"U"
+5 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
+6 LOCK -^PS(53.1,ODA)
LOCK -^PS(55,DFN,5,+PSGORD)
KILL CNT,ND,ODA,XX,ZND
QUIT
