- PSOARCF1 ;BHAM ISC/LGH,SAB,LC - hfs file index search ; 07/07/92
- ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- PQ S XNEW=0,PSOATNM=1 S %ZIS("A")="Host File Server Device: ",%ZIS("B")="",%ZIS("HFSMODE")="R"
- W !! D ^%ZIS K %ZIS("A") G END:POP S (PSOAT,PSOAIO)=IO,PSOAIOT=IOT,PSOAPAR=IOPAR
- I IOT'="HFS" D ^%ZISC U IO(0) W !,"Must select a HFS device",!! G PQ
- U IO(0) W !! S %ZIS("A")="Output Device: " D ^%ZIS K %ZIS("A") S PSOAP=IO G END:POP S PSOACPM=IOM,PSOACPF=IOF,PSOACPL=IOSL W !!
- S PSORWND=$$REWIND^%ZIS(PSOAT,PSOAIOT,PSOAPAR) G END:$G(PSORWND)=0
- R2 S DIR("A")="Do you want to print the file index",DIR("T")=DTIME,DIR(0)="YO" D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT) END G:'Y RN
- F U PSOAT R X:DTIME U PSOAP W !,X Q:X="!"
- RWD U PSOAT S PSORWND=$$REWIND^%ZIS(PSOAT,PSOAIOT,PSOAPAR) U IO(0)
- RN W !! S DIR("A")="Enter Patient Name ",DIR("?")="^D QNM^PSOARCF1",DIR("T")=DTIME,DIR(0)="FO" D ^DIR K DIR G:$G(DIRUT) END S DIC=2,DIC(0)="EZM" D ^DIC K DIC S NM=$S(Y=-1:"",1:$P(Y,"^",2)),TZ=1,SS=$S(Y=-1:"",1:$P(Y(0),"^",9))
- I Y=-1 S:X?1A.E NM=X S:X?9N SS=X
- R U PSOAT R X:DTIME G:$$STATUS^%ZISH END D:(X="")!(X="!") NOT
- I X="&^NEW" S XNEW=1 G R5
- I X="&" S XNEW=0 G R5
- S XNM=$P($P(X,"^"),"%",1),XSS=$P($P(X,"^"),"%",2) G R5:((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS)) S ^TMP($J,"ZRX",TZ)=X,TZ=TZ+1 G R1
- R5 U PSOAT R X:DTIME S Y=$$STATUS^%ZISH G:Y END G:(X="")!(X="!") NOT S XNM=$P($P(X,"^"),"%",1),XSS=$P($P(X,"^"),"%",2) G R5:((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS)) S ^TMP($J,"ZRX",TZ)=X,TZ=TZ+1
- R1 R X:DTIME G:'$T END G P:(X="")!(X="!")!($E(X,1)?1A) S ^TMP($J,"ZRX",TZ)=X,TZ=TZ+1 G R1
- P S TZ=TZ-1
- U PSOAP W @PSOACPF,!,"THE FOLLOWING SCRIPTS WERE ARCHIVED FOR : ",!!
- W !,$P(^TMP($J,"ZRX",1),"%",1)," (",$P($P(^(1),"^"),"%",2),") - " S NM=$P(^TMP($J,"ZRX",1),"%",1),SS=$P($P(^(1),"^"),"%",2) F I=1:1:TZ W:I'=1 !?($L(NM)+2) W $P(^TMP($J,"ZRX",I),"^",2)
- S PSOAPG=1,PSOACDS="RX RETRIEVAL FOR "_NM D:XNEW=0 ^PSOARCF3 D:XNEW=1 ^PSOARCF2 G RWD
- Q
- NOT U IO(0) W !!,NM," does not have any archived scripts." K NM,X,Y,TZ,SS G RWD
- END I $D(PSOAT) U IO(0) S IOP=PSOAT D ^%ZIS D ^%ZISC K IOP
- I $D(PSOAP) U IO(0) S IOP=PSOAP D ^%ZIS D ^%ZISC K IOP
- K ^TMP($J,"ZRX"),TZ,NMPSOAT,PSOAP,PSOACPM,PSOACPF,PSOACPL,XNEW,PSOAPF,TEST,%MT,DIRUT,I,NM,POP,PSOACDS,PSOAPG,PSOAT,SS,X,XNM,XSS,Y
- K PSOAIO,PSOAIOT,PSOAPAR,PSORWND
- Q
- QNM W !!,"Enter the Name or Social Security Number of the patient whose archived",!,"prescriptions you wish to retrieve. Social Security Number must be in the",!,"form : ######### (NO DASHES)!!"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCF1 2561 printed Mar 13, 2025@21:29:04 Page 2
- PSOARCF1 ;BHAM ISC/LGH,SAB,LC - hfs file index search ; 07/07/92
- +1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- PQ SET XNEW=0
- SET PSOATNM=1
- SET %ZIS("A")="Host File Server Device: "
- SET %ZIS("B")=""
- SET %ZIS("HFSMODE")="R"
- +1 WRITE !!
- DO ^%ZIS
- KILL %ZIS("A")
- if POP
- GOTO END
- SET (PSOAT,PSOAIO)=IO
- SET PSOAIOT=IOT
- SET PSOAPAR=IOPAR
- +2 IF IOT'="HFS"
- DO ^%ZISC
- USE IO(0)
- WRITE !,"Must select a HFS device",!!
- GOTO PQ
- +3 USE IO(0)
- WRITE !!
- SET %ZIS("A")="Output Device: "
- DO ^%ZIS
- KILL %ZIS("A")
- SET PSOAP=IO
- if POP
- GOTO END
- SET PSOACPM=IOM
- SET PSOACPF=IOF
- SET PSOACPL=IOSL
- WRITE !!
- +4 SET PSORWND=$$REWIND^%ZIS(PSOAT,PSOAIOT,PSOAPAR)
- if $GET(PSORWND)=0
- GOTO END
- R2 SET DIR("A")="Do you want to print the file index"
- SET DIR("T")=DTIME
- SET DIR(0)="YO"
- DO ^DIR
- KILL DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- GOTO END
- if 'Y
- GOTO RN
- +1 FOR
- USE PSOAT
- READ X:DTIME
- USE PSOAP
- WRITE !,X
- if X="!"
- QUIT
- RWD USE PSOAT
- SET PSORWND=$$REWIND^%ZIS(PSOAT,PSOAIOT,PSOAPAR)
- USE IO(0)
- RN WRITE !!
- SET DIR("A")="Enter Patient Name "
- SET DIR("?")="^D QNM^PSOARCF1"
- SET DIR("T")=DTIME
- SET DIR(0)="FO"
- DO ^DIR
- KILL DIR
- if $GET(DIRUT)
- GOTO END
- SET DIC=2
- SET DIC(0)="EZM"
- DO ^DIC
- KILL DIC
- SET NM=$SELECT(Y=-1:"",1:$PIECE(Y,"^",2))
- SET TZ=1
- SET SS=$SELECT(Y=-1:"",1:$PIECE(Y(0),"^",9))
- +1 IF Y=-1
- if X?1A.E
- SET NM=X
- if X?9N
- SET SS=X
- R USE PSOAT
- READ X:DTIME
- if $$STATUS^%ZISH
- GOTO END
- if (X="")!(X="!")
- DO NOT
- +1 IF X="&^NEW"
- SET XNEW=1
- GOTO R5
- +2 IF X="&"
- SET XNEW=0
- GOTO R5
- +3 SET XNM=$PIECE($PIECE(X,"^"),"%",1)
- SET XSS=$PIECE($PIECE(X,"^"),"%",2)
- if ((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS))
- GOTO R5
- SET ^TMP($JOB,"ZRX",TZ)=X
- SET TZ=TZ+1
- GOTO R1
- R5 USE PSOAT
- READ X:DTIME
- SET Y=$$STATUS^%ZISH
- if Y
- GOTO END
- if (X="")!(X="!")
- GOTO NOT
- SET XNM=$PIECE($PIECE(X,"^"),"%",1)
- SET XSS=$PIECE($PIECE(X,"^"),"%",2)
- if ((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS))
- GOTO R5
- SET ^TMP($JOB,"ZRX",TZ)=X
- SET TZ=TZ+1
- R1 READ X:DTIME
- if '$TEST
- GOTO END
- if (X="")!(X="!")!($EXTRACT(X,1)?1A)
- GOTO P
- SET ^TMP($JOB,"ZRX",TZ)=X
- SET TZ=TZ+1
- GOTO R1
- P SET TZ=TZ-1
- +1 USE PSOAP
- WRITE @PSOACPF,!,"THE FOLLOWING SCRIPTS WERE ARCHIVED FOR : ",!!
- +2 WRITE !,$PIECE(^TMP($JOB,"ZRX",1),"%",1)," (",$PIECE($PIECE(^(1),"^"),"%",2),") - "
- SET NM=$PIECE(^TMP($JOB,"ZRX",1),"%",1)
- SET SS=$PIECE($PIECE(^(1),"^"),"%",2)
- FOR I=1:1:TZ
- if I'=1
- WRITE !?($LENGTH(NM)+2)
- WRITE $PIECE(^TMP($JOB,"ZRX",I),"^",2)
- +3 SET PSOAPG=1
- SET PSOACDS="RX RETRIEVAL FOR "_NM
- if XNEW=0
- DO ^PSOARCF3
- if XNEW=1
- DO ^PSOARCF2
- GOTO RWD
- +4 QUIT
- NOT USE IO(0)
- WRITE !!,NM," does not have any archived scripts."
- KILL NM,X,Y,TZ,SS
- GOTO RWD
- END IF $DATA(PSOAT)
- USE IO(0)
- SET IOP=PSOAT
- DO ^%ZIS
- DO ^%ZISC
- KILL IOP
- +1 IF $DATA(PSOAP)
- USE IO(0)
- SET IOP=PSOAP
- DO ^%ZIS
- DO ^%ZISC
- KILL IOP
- +2 KILL ^TMP($JOB,"ZRX"),TZ,NMPSOAT,PSOAP,PSOACPM,PSOACPF,PSOACPL,XNEW,PSOAPF,TEST,%MT,DIRUT,I,NM,POP,PSOACDS,PSOAPG,PSOAT,SS,X,XNM,XSS,Y
- +3 KILL PSOAIO,PSOAIOT,PSOAPAR,PSORWND
- +4 QUIT
- QNM WRITE !!,"Enter the Name or Social Security Number of the patient whose archived",!,"prescriptions you wish to retrieve. Social Security Number must be in the",!,"form : ######### (NO DASHES)!!"
- +1 QUIT
