- PSGOT ;BIR/CML3 - TRANSFERS DATA FROM 53.1 TO 55 ;Jun 17, 2020@15:27:28
- ;;5.0;INPATIENT MEDICATIONS;**13,68,90,110,173,134,161,254,267,257,315,327,399**;16 DEC 97;Build 64
- ;
- ; 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)
- S (ND2P1,^PS(55,PSGP,5,DA,2.1))=$G(^PS(53.1,ODA,2.1)),^PS(55,PSGP,5,DA,4)=$G(^PS(53.1,ODA,4)),^PS(55,"AUD",+$P(ND2,"^",4),PSGP,DA)=""
- ;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),(ND2P1,^PS(55,PSGP,5,DA,2.1))=$G(^PS(53.1,ODA,2.1)) ;*315 DRP
- S ^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)
- S ^PS(55,PSGP,5,DA,18)=$G(^PS(53.1,ODA,18)) ;*399-IND
- I $D(^PS(53.1,ODA,"DSS")) S ^PS(55,PSGP,5,DA,8)=^("DSS") D CIMOU^PSJIMO1(PSGP,DA,"",ODA)
- 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
- ;; START NCC REMEDIATION >> 327*RJS
- N CLOZFLG S CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,DA) I $G(CLOZFLG) D
- .N DIE,DR S DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP,DR="301////"
- .I $D(^TMP("PSJCOM",$J,ODA,"SAND")) D K ^TMP("PSJCOM",$J,ODA,"SAND") I 1
- ..S DR=DR_$G(^TMP("PSJCOM",$J,ODA,"SAND"))
- .E I $G(^TMP($J,"PSGCLOZ",PSGP,ODA,"SAND")) D K ^TMP($J,"PSGCLOZ",PSGP,ODA,"SAND")
- ..S DR=DR_$G(^TMP($J,"PSGCLOZ",PSGP,ODA,"SAND"))
- .D ^DIE
- ;; END NCC REMEDIATION >> 327*RJS
- D SETUDINT^PSGSICH1(ODA_"P",DA_"U")
- 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"
- N PSJTMPTX,PSJOVRMX,PSJTMPLIN
- 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
- I $D(^PS(53.1,+ODA,15,0)) S ^PS(55,PSGP,5,DA,15,0)="^55.6135^"_$P($G(^PS(53.1,+ODA,15,0)),"^",3)_"^"_$P($G(^PS(53.1,+ODA,15,0)),"^",4) D
- .N LN,LNCNT,SIMSG S SIMSG="Instructions too long. See Order View or BCMA for full text."
- .S LNCNT=0,LN=9999 F S LN=$O(^PS(53.1,+ODA,15,LN),-1) Q:'LN D
- ..I 'LNCNT,($G(^PS(53.1,+ODA,15,LN,0))="") Q
- ..S ^PS(55,PSGP,5,DA,15,LN,0)=^PS(53.1,+ODA,15,LN,0) S LNCNT=LNCNT+1
- .I LNCNT S $P(^PS(55,PSGP,5,DA,15,0),"^",3,4)=LNCNT_"^"_LNCNT
- .S PSJTMPTX="",PSJOVRMX=0 S TMPLIN=0 F S TMPLIN=$O(^PS(55,+DFN,5,DA,15,TMPLIN)) Q:'TMPLIN!(PSJOVRMX) D
- ..S:($L(PSJTMPTX)+$L($G(^PS(55,+DFN,5,DA,15,TMPLIN,0))))>180 PSJOVRMX=1 Q:$G(PSJOVRMX) S PSJTMPTX=$G(PSJTMPTX)_$S($G(PSJTMPTX)]"":" ",1:"")_$G(^PS(55,+DFN,5,DA,15,TMPLIN,0))
- .S TXT=$S(PSJOVRMX:SIMSG,1:PSJTMPTX)
- .S:($TR(TXT,"^ ")="")!'($D(^PS(55,PSGP,5,DA,15,1))) TXT="" S ^PS(55,PSGP,5,DA,6)=TXT S $P(^PS(55,PSGP,5,DA,6),"^",2)=$P(^PS(53.1,+ODA,6),"^",2)
- .N LSTLNUM,LSTLNTXT S LSTLNUM=$O(^PS(55,+PSGP,5,+DA,15,""),-1) I LSTLNUM>1 S LSTLNTXT=$G(^PS(55,+PSGP,5,+DA,15,LSTLNUM,0)) I $TR(LSTLNTXT," ")="" D
- ..K ^PS(55,+PSGP,5,+DA,15,LSTLNUM,0)
- L -^PS(53.1,+ODA) L -^PS(55,PSGP,5,+DA) K CNT,ND,ODA,XX,ZND
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOT 5522 printed Feb 18, 2025@23:28:58 Page 2
- PSGOT ;BIR/CML3 - TRANSFERS DATA FROM 53.1 TO 55 ;Jun 17, 2020@15:27:28
- +1 ;;5.0;INPATIENT MEDICATIONS;**13,68,90,110,173,134,161,254,267,257,315,327,399**;16 DEC 97;Build 64
- +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)
- +5 SET (ND2P1,^PS(55,PSGP,5,DA,2.1))=$GET(^PS(53.1,ODA,2.1))
- SET ^PS(55,PSGP,5,DA,4)=$GET(^PS(53.1,ODA,4))
- SET ^PS(55,"AUD",+$PIECE(ND2,"^",4),PSGP,DA)=""
- +6 ;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),(ND2P1,^PS(55,PSGP,5,DA,2.1))=$G(^PS(53.1,ODA,2.1)) ;*315 DRP
- +7 SET ^PS(55,PSGP,5,DA,4)=$GET(^PS(53.1,ODA,4))
- SET ^PS(55,"AUD",+$PIECE(ND2,"^",4),PSGP,DA)=""
- +8 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)
- +9 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)
- +10 FOR X=6,7,13
- IF $DATA(^PS(53.1,ODA,X))
- SET ^PS(55,PSGP,5,DA,X)=^(X)
- +11 ;*399-IND
- SET ^PS(55,PSGP,5,DA,18)=$GET(^PS(53.1,ODA,18))
- +12 IF $DATA(^PS(53.1,ODA,"DSS"))
- SET ^PS(55,PSGP,5,DA,8)=^("DSS")
- DO CIMOU^PSJIMO1(PSGP,DA,"",ODA)
- +13 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)=""
- +14 IF $ORDER(^PS(53.1,ODA,1,0))
- SET ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
- +15 FOR X=3,12
- Begin DoDot:1
- +16 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
- +17 SET $PIECE(^PS(53.1,ODA,0),"^",19)=DA
- +18 ;; START NCC REMEDIATION >> 327*RJS
- +19 NEW CLOZFLG
- SET CLOZFLG=$$ISCLOZ^PSJCLOZ(,,PSGP,DA)
- IF $GET(CLOZFLG)
- Begin DoDot:1
- +20 NEW DIE,DR
- SET DIE="^PS(55,"_PSGP_",5,"
- SET DA(1)=PSGP
- SET DR="301////"
- +21 IF $DATA(^TMP("PSJCOM",$JOB,ODA,"SAND"))
- Begin DoDot:2
- +22 SET DR=DR_$GET(^TMP("PSJCOM",$JOB,ODA,"SAND"))
- End DoDot:2
- KILL ^TMP("PSJCOM",$JOB,ODA,"SAND")
- IF 1
- +23 IF '$TEST
- IF $GET(^TMP($JOB,"PSGCLOZ",PSGP,ODA,"SAND"))
- Begin DoDot:2
- +24 SET DR=DR_$GET(^TMP($JOB,"PSGCLOZ",PSGP,ODA,"SAND"))
- End DoDot:2
- KILL ^TMP($JOB,"PSGCLOZ",PSGP,ODA,"SAND")
- +25 DO ^DIE
- End DoDot:1
- +26 ;; END NCC REMEDIATION >> 327*RJS
- +27 DO SETUDINT^PSGSICH1(ODA_"P",DA_"U")
- 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 NEW PSJTMPTX,PSJOVRMX,PSJTMPLIN
- +2 SET PSGODA=ODA
- SET PSGORD=DA_"U"
- +3 SET PSGNODE=$GET(^PS(55,PSGP,5,DA,0))
- SET PSG25=$PIECE(PSGNODE,"^",25)
- SET PSG26=$PIECE(PSGNODE,"^",26)
- +4 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"
- +5 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"
- +6 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
- +7 IF $DATA(^PS(53.1,+ODA,15,0))
- SET ^PS(55,PSGP,5,DA,15,0)="^55.6135^"_$PIECE($GET(^PS(53.1,+ODA,15,0)),"^",3)_"^"_$PIECE($GET(^PS(53.1,+ODA,15,0)),"^",4)
- Begin DoDot:1
- +8 NEW LN,LNCNT,SIMSG
- SET SIMSG="Instructions too long. See Order View or BCMA for full text."
- +9 SET LNCNT=0
- SET LN=9999
- FOR
- SET LN=$ORDER(^PS(53.1,+ODA,15,LN),-1)
- if 'LN
- QUIT
- Begin DoDot:2
- +10 IF 'LNCNT
- IF ($GET(^PS(53.1,+ODA,15,LN,0))="")
- QUIT
- +11 SET ^PS(55,PSGP,5,DA,15,LN,0)=^PS(53.1,+ODA,15,LN,0)
- SET LNCNT=LNCNT+1
- End DoDot:2
- +12 IF LNCNT
- SET $PIECE(^PS(55,PSGP,5,DA,15,0),"^",3,4)=LNCNT_"^"_LNCNT
- +13 SET PSJTMPTX=""
- SET PSJOVRMX=0
- SET TMPLIN=0
- FOR
- SET TMPLIN=$ORDER(^PS(55,+DFN,5,DA,15,TMPLIN))
- if 'TMPLIN!(PSJOVRMX)
- QUIT
- Begin DoDot:2
- +14 if ($LENGTH(PSJTMPTX)+$LENGTH($GET(^PS(55,+DFN,5,DA,15,TMPLIN,0))))>180
- SET PSJOVRMX=1
- if $GET(PSJOVRMX)
- QUIT
- SET PSJTMPTX=$GET(PSJTMPTX)_$SELECT($GET(PSJTMPTX)]"":" ",1:"")_$GET(^PS(55,+DFN,5,DA,15,TMPLIN,0))
- End DoDot:2
- +15 SET TXT=$SELECT(PSJOVRMX:SIMSG,1:PSJTMPTX)
- +16 if ($TRANSLATE(TXT,"^ ")="")!'($DATA(^PS(55,PSGP,5,DA,15,1)))
- SET TXT=""
- SET ^PS(55,PSGP,5,DA,6)=TXT
- SET $PIECE(^PS(55,PSGP,5,DA,6),"^",2)=$PIECE(^PS(53.1,+ODA,6),"^",2)
- +17 NEW LSTLNUM,LSTLNTXT
- SET LSTLNUM=$ORDER(^PS(55,+PSGP,5,+DA,15,""),-1)
- IF LSTLNUM>1
- SET LSTLNTXT=$GET(^PS(55,+PSGP,5,+DA,15,LSTLNUM,0))
- IF $TRANSLATE(LSTLNTXT," ")=""
- Begin DoDot:2
- +18 KILL ^PS(55,+PSGP,5,+DA,15,LSTLNUM,0)
- End DoDot:2
- End DoDot:1
- +19 LOCK -^PS(53.1,+ODA)
- LOCK -^PS(55,PSGP,5,+DA)
- KILL CNT,ND,ODA,XX,ZND
- +20 QUIT
- +21 ;