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,267,257,255,315,343,413**;16 DEC 97;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 supported by DBIA 2191.
;
START(ODA,DA) ; lock record, and write
N OFD,PVND4,PSGPV 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)=""
S ND2P1=^PS(53.1,+ODA,2.1) ;*315
;PSJ*5*255 - Record renewing provider
I $P(^PS(53.1,+ODA,0),U,2)]"" S PSGPV=$P(^PS(53.1,+ODA,0),U,2) D
. N DR,DIE
. S DR="1////^S X=PSGPV",DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP D ^DIE
;End PSJ*5*255
;*413 Begin - Clinic location
I $P($G(^PS(53.1,+ODA,"DSS")),U,1)'="" D
. N DR,DIE,LCLIN
. S LCLIN=$P($G(^PS(53.1,+ODA,"DSS")),U,1)
. S DR="130////^S X=LCLIN",DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP D ^DIE
;*413 End
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:PSGOFD),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)
; PSJ*5.0*255/kill old "AU" x-ref of the last stop date
I $P(OND14,"^",4) F S="C","O","P","R","OC" K ^PS(55,PSGP,5,"AU",S,+$P(OND14,"^",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)
D CIMOU^PSJIMO1(PSGP,DA,"",ODA)
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
I $D(^PS(53.1,+ODA,15,0)) N SIARRAY D
.M SIARRAY=^PS(55,PSGP,5,+DA,15) I $$DIFFSI^PSJBCMA5(PSGP,+DA_"U") D NEWUDAL^PSGAL5(PSGP,+DA_"U",6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
.K ^PS(55,PSGP,5,DA,15) S ^PS(55,PSGP,5,DA,6)=$G(^PS(53.1,+ODA,6)) 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)
.N LN,LNCNT 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
.N TXT,LNCNT,SIMSG S LNCNT=$O(^PS(53.1,+ODA,15,""),-1) S SIMSG="Instructions too long. See Order View or BCMA for full text."
.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[HPSGOTR 4874 printed Sep 23, 2025@19:38:42 Page 2
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,267,257,255,315,343,413**;16 DEC 97;Build 9
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(55 supported by DBIA 2191.
+4 ;
START(ODA,DA) ; lock record, and write
+1 NEW OFD,PVND4,PSGPV
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 ;*315
SET ND2P1=^PS(53.1,+ODA,2.1)
+5 ;PSJ*5*255 - Record renewing provider
+6 IF $PIECE(^PS(53.1,+ODA,0),U,2)]""
SET PSGPV=$PIECE(^PS(53.1,+ODA,0),U,2)
Begin DoDot:1
+7 NEW DR,DIE
+8 SET DR="1////^S X=PSGPV"
SET DIE="^PS(55,"_PSGP_",5,"
SET DA(1)=PSGP
DO ^DIE
End DoDot:1
+9 ;End PSJ*5*255
+10 ;*413 Begin - Clinic location
+11 IF $PIECE($GET(^PS(53.1,+ODA,"DSS")),U,1)'=""
Begin DoDot:1
+12 NEW DR,DIE,LCLIN
+13 SET LCLIN=$PIECE($GET(^PS(53.1,+ODA,"DSS")),U,1)
+14 SET DR="130////^S X=LCLIN"
SET DIE="^PS(55,"_PSGP_",5,"
SET DA(1)=PSGP
DO ^DIE
End DoDot:1
+15 ;*413 End
+16 FOR X=6,7
IF $DATA(^PS(53.1,+ODA,X))
SET ^PS(55,PSGP,5,DA,X)=^(X)
+17 IF $ORDER(^PS(53.1,+ODA,1,0))
Begin DoDot:1
+18 KILL ^PS(55,PSGP,5,DA,1)
+19 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)=""
+20 SET ^PS(55,PSGP,5,DA,1,0)="^55.07P^"_C_"^"_C
End DoDot:1
+21 FOR X=3,12
Begin DoDot:1
+22 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
+23 SET $PIECE(^PS(53.1,+ODA,0),"^",19)=DA
+24 SET $PIECE(^PS(55,PSGP,5,DA,0),"^",7)=$PIECE(^PS(53.1,+ODA,0),"^",7)
+25 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)
+26 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)
+27 IF '$GET(DUOUT)
Begin DoDot:1
+28 IF $GET(PSJORD)["P"
NEW PSGFDO
SET PSGFDO=$$LASTREN^PSJLMPRI(PSGP,PSJORD)
SET PSGFDO=$PIECE(PSGFDO,"^",4)
+29 DO UPDREN^PSGOER(DA_"U",RNWDT,PSGOEPR,$SELECT($GET(PSGFDO):PSGFDO,1:PSGOFD),PSJNOO,RDUZ)
End DoDot:1
+30 SET PVND4=$GET(^PS(53.1,+ODA,4))
IF $PIECE(PVND4,"^")
IF $PIECE(PVND4,"^",2)
Begin DoDot:1
+31 NEW RNDT
SET RNDT=$$LASTREN^PSJLMPRI(DFN,+ODA_"P")
if RNDT>$PIECE(PVND4,"^",2)
QUIT
+32 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 ; PSJ*5.0*255/kill old "AU" x-ref of the last stop date
+5 IF $PIECE(OND14,"^",4)
FOR S="C","O","P","R","OC"
KILL ^PS(55,PSGP,5,"AU",S,+$PIECE(OND14,"^",4),DA)
+6 SET ^PS(55,PSGP,5,"AU",$PIECE(PSGPND0,"^",7),+$PIECE(PSGPND2,"^",4),DA)=""
+7 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)
+8 DO CIMOU^PSJIMO1(PSGP,DA,"",ODA)
+9 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")
+10 KILL DIK
SET DA(1)=PSGP
SET DIK="^PS(55,"_DA(1)_",5,"
SET DIK(1)=125
DO EN1^DIK
KILL DIK
+11 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 IF $DATA(^PS(53.1,+ODA,15,0))
NEW SIARRAY
Begin DoDot:1
+4 MERGE SIARRAY=^PS(55,PSGP,5,+DA,15)
IF $$DIFFSI^PSJBCMA5(PSGP,+DA_"U")
DO NEWUDAL^PSGAL5(PSGP,+DA_"U",6000,"SPECIAL INSTRUCTIONS",,.SIARRAY)
+5 KILL ^PS(55,PSGP,5,DA,15)
SET ^PS(55,PSGP,5,DA,6)=$GET(^PS(53.1,+ODA,6))
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)
+6 NEW LN,LNCNT
SET LNCNT=0
SET LN=9999
FOR
SET LN=$ORDER(^PS(53.1,+ODA,15,LN),-1)
if 'LN
QUIT
Begin DoDot:2
+7 IF 'LNCNT
IF ($GET(^PS(53.1,+ODA,15,LN,0))="")
QUIT
+8 SET ^PS(55,PSGP,5,DA,15,LN,0)=^PS(53.1,+ODA,15,LN,0)
SET LNCNT=LNCNT+1
End DoDot:2
+9 IF LNCNT
SET $PIECE(^PS(55,PSGP,5,DA,15,0),"^",3,4)=LNCNT_"^"_LNCNT
+10 NEW TXT,LNCNT,SIMSG
SET LNCNT=$ORDER(^PS(53.1,+ODA,15,""),-1)
SET SIMSG="Instructions too long. See Order View or BCMA for full text."
+11 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
+12 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
+13 SET TXT=$SELECT(PSJOVRMX:SIMSG,1:PSJTMPTX)
+14 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)
+15 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
+16 KILL ^PS(55,+PSGP,5,+DA,15,LSTLNUM,0)
End DoDot:2
End DoDot:1
+17 LOCK -^PS(53.1,+ODA)
LOCK -^PS(55,PSGP,5,+DA)
KILL CNT,ND,ODA,XX,ZND
QUIT
