PSORMRXD ;BIRM/JAM - REMOTE DATA INTEROPERABILITY UTILITY ; 10/29/08
;;7.0;OUTPATIENT PHARMACY;**320**;DEC 1997;Build 2
;;
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN(PSOSEL) ;- ListManager entry point
;
D EN^VALM("PSO RDI VISITS DETAIL")
D FULL^VALM1
G EXIT
;
HDR ; Patient Header for remote site
D HDR^PSORMRX
I PSOSEL="DO" S VALM("TITLE")="Medication Profile - Remote"
I PSOSEL="DB" S VALM("TITLE")="Medication Profile - Both"
Q
;
INIT ; - Populates the Body section for ListMan
S VALMCNT=0
D DETAIL
S VALMSG="Enter ?? for more actions"
Q
;
DETAIL ; Build prescription details for local site
N SEQ,ST,DRG,DATA,NODE0,NODE1,PSOX,ISDT,QTY,LFDT,PSOSD,PSODTCUT,LINE,RX
N FSIG,PRVDR,SIG,STA,LC,CNT
; - get the last sequence number for remote prescriptions
S SEQ=$O(^TMP("PSORDI",$J,"A"),-1)
I PSOSEL="DO" S VALMCNT=$S(SEQ:SEQ,1:1) D Q
.; if no remote sites, set display reasons if available
.I '+$O(^TMP("PSORDI",$J,0)),$D(^TMP($J,"PSORDI",1)) S LC="",CNT=0 D
..F S LC=$O(^TMP($J,"PSORDI",LC)) Q:LC="" D
...S CNT=CNT+1,^TMP("PSORDI",$J,CNT,0)=" "_$G(^TMP($J,"PSORDI",LC,0))
; get local prescriptions
S PSODTCUT=$$FMADD^XLFDT(DT,-90)
D ^PSOBUILD
I +SEQ<1 S SEQ=0
I SEQ>1 S LINE="" D SETTMP
I $D(PSOSD) D
.S LINE="LOCAL PRESCRIPTIONS" D SETTMP
S (LINE,ST)=""
F S ST=$O(PSOSD(ST)) Q:ST="" D
.S (LINE,DRG)="" F S DRG=$O(PSOSD(ST,DRG)) Q:DRG="" D
..S DATA=PSOSD(ST,DRG)
..S NODE0=$G(^PSRX(+$P(DATA,"^"),0)),LFDT=+$G(^(3)) I NODE0="" Q
..S STA=$$STACHK^PSORMRX(ST,$P($G(^PSRX(+$P(DATA,"^"),2)),"^",6))
..I '+STA Q
..S STA=$P(STA,"^",2)
..S LINE=$P(NODE0,"^"),$E(LINE,15)=$E(DRG,1,34)
..S $E(LINE,50)=$S(STA="DISCONTINUED":"DC",1:$E(STA))
..S QTY=$P(NODE0,"^",7),ISDT=$P(NODE0,"^",13)
..S $E(LINE,53)=$J(+QTY,4),$E(LINE,60)=$$FMTE^XLFDT(ISDT,"2ZM")
..F PSOX=0:0 S PSOX=$O(^PSRX(+$P(DATA,"^"),1,PSOX)) Q:'PSOX D
...S NODE1=$G(^PSRX(+$P(DATA,"^"),1,PSOX,0))
...I +NODE1=LFDT,$P(NODE1,"^",16) S LFDT=LFDT_"^R"
..I '$O(^PSRX(+$P(DATA,"^"),1,0)),$P($G(^PSRX(+$P(DATA,"^"),2)),"^",15) D
...S LFDT=LFDT_"^R"
..S $E(LINE,70)=$$FMTE^XLFDT(LFDT,"2ZM")
..D SETTMP
..K FSIG D GETSIG
..S LINE="",$E(LINE,15)="SIG: ",SIG=0
..F S SIG=$O(FSIG(SIG)) Q:'SIG D
...S $E(LINE,20)=FSIG(SIG) D SETTMP S LINE=""
..I $O(FSIG(""))="" D SETTMP
..S PRVDR=$P($G(^PSRX(+$P(DATA,"^"),0)),"^",4),LINE=""
..S $E(LINE,15)="PROVIDER: "_$$UP^XLFSTR($$NAME^XUSER(PRVDR,"F"))
..D SETTMP S LINE=""
S VALMCNT=SEQ
Q
;
SETTMP ;Sets the ^TMP("PSORDI",$J global
S SEQ=SEQ+1,^TMP("PSORDI",$J,SEQ,0)=LINE
Q
;
GETSIG ;Gets SIG from File #52, format and place into FSIG array
N I,RSIG
S I=0 F S I=$O(^PSRX(+$P(DATA,"^"),"SIG1",I)) Q:'I D
.S RSIG(I)=$G(^PSRX(+$P(DATA,"^"),"SIG1",I,0))
I $O(RSIG(""))'="" D FMTSIG^PSORMRX
Q
;
HELP ;
Q
;
EXIT ;
;Remove local but leave remote prescriptions
N CNT,SEQ
I '$D(PSORFLG) D Q
.K ^TMP("PSORDI",$J),^TMP($J,"PSORDI"),^TMP("PSORDIS",$J)
S SEQ=$G(^TMP("PSORDI",$J,"REMOTE COUNT"))
F S SEQ=$O(^TMP("PSORDI",$J,SEQ)) Q:'SEQ K ^TMP("PSORDI",$J,SEQ)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORMRXD 3147 printed Apr 09, 2024@21:30:25 Page 2
PSORMRXD ;BIRM/JAM - REMOTE DATA INTEROPERABILITY UTILITY ; 10/29/08
+1 ;;7.0;OUTPATIENT PHARMACY;**320**;DEC 1997;Build 2
+2 ;;
+3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
EN(PSOSEL) ;- ListManager entry point
+1 ;
+2 DO EN^VALM("PSO RDI VISITS DETAIL")
+3 DO FULL^VALM1
+4 GOTO EXIT
+5 ;
HDR ; Patient Header for remote site
+1 DO HDR^PSORMRX
+2 IF PSOSEL="DO"
SET VALM("TITLE")="Medication Profile - Remote"
+3 IF PSOSEL="DB"
SET VALM("TITLE")="Medication Profile - Both"
+4 QUIT
+5 ;
INIT ; - Populates the Body section for ListMan
+1 SET VALMCNT=0
+2 DO DETAIL
+3 SET VALMSG="Enter ?? for more actions"
+4 QUIT
+5 ;
DETAIL ; Build prescription details for local site
+1 NEW SEQ,ST,DRG,DATA,NODE0,NODE1,PSOX,ISDT,QTY,LFDT,PSOSD,PSODTCUT,LINE,RX
+2 NEW FSIG,PRVDR,SIG,STA,LC,CNT
+3 ; - get the last sequence number for remote prescriptions
+4 SET SEQ=$ORDER(^TMP("PSORDI",$JOB,"A"),-1)
+5 IF PSOSEL="DO"
SET VALMCNT=$SELECT(SEQ:SEQ,1:1)
Begin DoDot:1
+6 ; if no remote sites, set display reasons if available
+7 IF '+$ORDER(^TMP("PSORDI",$JOB,0))
IF $DATA(^TMP($JOB,"PSORDI",1))
SET LC=""
SET CNT=0
Begin DoDot:2
+8 FOR
SET LC=$ORDER(^TMP($JOB,"PSORDI",LC))
if LC=""
QUIT
Begin DoDot:3
+9 SET CNT=CNT+1
SET ^TMP("PSORDI",$JOB,CNT,0)=" "_$GET(^TMP($JOB,"PSORDI",LC,0))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+10 ; get local prescriptions
+11 SET PSODTCUT=$$FMADD^XLFDT(DT,-90)
+12 DO ^PSOBUILD
+13 IF +SEQ<1
SET SEQ=0
+14 IF SEQ>1
SET LINE=""
DO SETTMP
+15 IF $DATA(PSOSD)
Begin DoDot:1
+16 SET LINE="LOCAL PRESCRIPTIONS"
DO SETTMP
End DoDot:1
+17 SET (LINE,ST)=""
+18 FOR
SET ST=$ORDER(PSOSD(ST))
if ST=""
QUIT
Begin DoDot:1
+19 SET (LINE,DRG)=""
FOR
SET DRG=$ORDER(PSOSD(ST,DRG))
if DRG=""
QUIT
Begin DoDot:2
+20 SET DATA=PSOSD(ST,DRG)
+21 SET NODE0=$GET(^PSRX(+$PIECE(DATA,"^"),0))
SET LFDT=+$GET(^(3))
IF NODE0=""
QUIT
+22 SET STA=$$STACHK^PSORMRX(ST,$PIECE($GET(^PSRX(+$PIECE(DATA,"^"),2)),"^",6))
+23 IF '+STA
QUIT
+24 SET STA=$PIECE(STA,"^",2)
+25 SET LINE=$PIECE(NODE0,"^")
SET $EXTRACT(LINE,15)=$EXTRACT(DRG,1,34)
+26 SET $EXTRACT(LINE,50)=$SELECT(STA="DISCONTINUED":"DC",1:$EXTRACT(STA))
+27 SET QTY=$PIECE(NODE0,"^",7)
SET ISDT=$PIECE(NODE0,"^",13)
+28 SET $EXTRACT(LINE,53)=$JUSTIFY(+QTY,4)
SET $EXTRACT(LINE,60)=$$FMTE^XLFDT(ISDT,"2ZM")
+29 FOR PSOX=0:0
SET PSOX=$ORDER(^PSRX(+$PIECE(DATA,"^"),1,PSOX))
if 'PSOX
QUIT
Begin DoDot:3
+30 SET NODE1=$GET(^PSRX(+$PIECE(DATA,"^"),1,PSOX,0))
+31 IF +NODE1=LFDT
IF $PIECE(NODE1,"^",16)
SET LFDT=LFDT_"^R"
End DoDot:3
+32 IF '$ORDER(^PSRX(+$PIECE(DATA,"^"),1,0))
IF $PIECE($GET(^PSRX(+$PIECE(DATA,"^"),2)),"^",15)
Begin DoDot:3
+33 SET LFDT=LFDT_"^R"
End DoDot:3
+34 SET $EXTRACT(LINE,70)=$$FMTE^XLFDT(LFDT,"2ZM")
+35 DO SETTMP
+36 KILL FSIG
DO GETSIG
+37 SET LINE=""
SET $EXTRACT(LINE,15)="SIG: "
SET SIG=0
+38 FOR
SET SIG=$ORDER(FSIG(SIG))
if 'SIG
QUIT
Begin DoDot:3
+39 SET $EXTRACT(LINE,20)=FSIG(SIG)
DO SETTMP
SET LINE=""
End DoDot:3
+40 IF $ORDER(FSIG(""))=""
DO SETTMP
+41 SET PRVDR=$PIECE($GET(^PSRX(+$PIECE(DATA,"^"),0)),"^",4)
SET LINE=""
+42 SET $EXTRACT(LINE,15)="PROVIDER: "_$$UP^XLFSTR($$NAME^XUSER(PRVDR,"F"))
+43 DO SETTMP
SET LINE=""
End DoDot:2
End DoDot:1
+44 SET VALMCNT=SEQ
+45 QUIT
+46 ;
SETTMP ;Sets the ^TMP("PSORDI",$J global
+1 SET SEQ=SEQ+1
SET ^TMP("PSORDI",$JOB,SEQ,0)=LINE
+2 QUIT
+3 ;
GETSIG ;Gets SIG from File #52, format and place into FSIG array
+1 NEW I,RSIG
+2 SET I=0
FOR
SET I=$ORDER(^PSRX(+$PIECE(DATA,"^"),"SIG1",I))
if 'I
QUIT
Begin DoDot:1
+3 SET RSIG(I)=$GET(^PSRX(+$PIECE(DATA,"^"),"SIG1",I,0))
End DoDot:1
+4 IF $ORDER(RSIG(""))'=""
DO FMTSIG^PSORMRX
+5 QUIT
+6 ;
HELP ;
+1 QUIT
+2 ;
EXIT ;
+1 ;Remove local but leave remote prescriptions
+2 NEW CNT,SEQ
+3 IF '$DATA(PSORFLG)
Begin DoDot:1
+4 KILL ^TMP("PSORDI",$JOB),^TMP($JOB,"PSORDI"),^TMP("PSORDIS",$JOB)
End DoDot:1
QUIT
+5 SET SEQ=$GET(^TMP("PSORDI",$JOB,"REMOTE COUNT"))
+6 FOR
SET SEQ=$ORDER(^TMP("PSORDI",$JOB,SEQ))
if 'SEQ
QUIT
KILL ^TMP("PSORDI",$JOB,SEQ)
+7 QUIT
