Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOSULOG

PSOSULOG.m

Go to the documentation of this file.
  1. PSOSULOG ;BHAM ISC/RTR-Log of prescriptions on suspense by day ; 11/18/92
  1. ;;7.0;OUTPATIENT PHARMACY;**18,264,362,753**;DEC 1997;Build 53
  1. I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) D WARN^PSOSUDCN Q
  1. K ^TMP($J,"PSOSPLOG") N BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
  1. LOG W ! K DIR S DIR("A")="Sort by Patient Name or SSN",DIR(0)="SB^P:PATIENT NAME;S:SOCIAL SECURITY NUMBER",DIR("B")="PATIENT NAME"
  1. S DIR("?")="Enter 'P' to sort by patient name, 'S' to sort by SSN, enter '^' to exit."
  1. D ^DIR K DIR D:$D(DIRUT) MESS G:$D(DIRUT) EXIT S PSORT=Y
  1. DATE W ! K %DT S %DT="AEX",%DT("A")="Start Date: " D ^%DT K %DT G:Y=-1&(X'["^") DATE I X["^"!($D(DTOUT)) D MESS G EXIT
  1. EDATE W ! S BDATE=$E(Y,1,7) S %DT(0)=BDATE,%DT="AEX",%DT("A")="End Date: " D ^%DT K %DT G:Y=-1&(X'["^") EDATE I X["^"!($D(DTOUT)) D MESS G EXIT
  1. S EDATE=$E(Y,1,7) W !
  1. W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to see only those Rx's that have NOT yet been printed" D ^DIR K DIR D:$D(DIRUT) MESS G:Y["^"!($D(DIRUT)) EXIT S PSPRINT=$S(Y:1,1:0)
  1. S PSOCNT=0 F PII=0:0 S PII=$O(^PS(59,PII)) Q:'PII S PSOCNT=PSOCNT+1
  1. I PSOCNT=1 G SKIP
  1. W !!?3,"You are logged in under the "_$P($G(^PS(59,+$G(PSOSITE),0)),"^")_" division.",!
  1. K DIR S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Print only those Rx's suspended for this division",DIR("?")="Enter 'Yes' to print only those Rx's for this division, enter 'No' to print Rx's suspended for all divisions."
  1. D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
  1. S PSUSDIV=Y
  1. SKIP ;
  1. I '$G(PSXSYS) G SKIPC
  1. K DIR W ! S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want suspended CMOP Rx's included in this report" D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
  1. I $G(Y) S PSOSCMOP=1
  1. SKIPC ;
  1. W ! K DIR S DIR("A")="Do you want this report to print in 80 or 132 column format: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80" D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS G EXIT
  1. W ! S PSORMZ=$S(Y=1:1,1:0)
  1. K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I POP D MESS G EXIT
  1. I $D(IO("Q")) S ZTRTN="REP^PSOSULOG",ZTDESC="Report is suspended Rx's" D G EXIT
  1. .F GG="PSORMZ","PSOSITE","PSOPAR","PSORT","BDATE","EDATE","PSPRINT","PSUSDIV","PSOSCMOP" S:$D(@GG) ZTSAVE(GG)=""
  1. .D ^%ZTLOAD W !,"Task queued to print"
  1. G REP
  1. EXIT ;
  1. K ^TMP($J,"PSOSPLOG") S:$D(ZTQUEUED) ZTREQ="@"
  1. K BDATE,EDATE,GG,HDAT,HPAT,PII,LINE,NODE,PAGE,PAT,PATNAME,PATPTR,PDAT,PP,PSOBAD,PSOSCMOP,PSOCNT,PSODATE,PSODATEX,PSOINRX,PSORMZ,PSORT,PSPRINT,PSUSDIV,QFLAG,SIN,SINRX,X,Y,ZZ
  1. Q
  1. MESS W !!,"No report printed!",!! Q
  1. REP ;
  1. K ^TMP($J,"PSOSPLOG")
  1. U IO S $P(LINE,"-",$S($G(PSORMZ):130,1:79))=""
  1. S BDATE=BDATE-.0001,QFLAG=0,PAGE=1
  1. F ZZ=BDATE:0 S ZZ=$O(^PS(52.5,"C",ZZ)) Q:'ZZ!(ZZ>EDATE) F SIN=0:0 S SIN=$O(^PS(52.5,"C",ZZ,SIN)) Q:'SIN D
  1. .Q:'$P($G(^PS(52.5,SIN,0)),"^",3)
  1. .I $G(PSPRINT),$G(^PS(52.5,SIN,"P")) Q
  1. .I '$G(PSOSCMOP),$P($G(^PS(52.5,SIN,0)),"^",7)'="" Q
  1. .I $G(PSUSDIV),$G(PSOSITE)'=$P($G(^PS(52.5,SIN,0)),"^",6) Q
  1. .S PAT=+$P($G(^PS(52.5,SIN,0)),"^",3) I $P($G(^DPT(PAT,0)),"^")="" Q
  1. .I $P($G(^DPT(PAT,0)),"^",9)="",PSORT="S" Q
  1. .S ^TMP($J,"PSOSPLOG",ZZ,$S(PSORT="P":$P(^DPT(PAT,0),"^"),1:$P(^DPT(PAT,0),"^",9)),SIN)=SIN
  1. I $G(PSORMZ) G BIG
  1. I '$D(^TMP($J,"PSOSPLOG")) D HEAD W !!,"NO RECORDS TO PRINT",! D:$E(IOST)="C" D ^%ZISC G EXIT
  1. .K DIR S DIR(0)="E" D ^DIR K DIR
  1. S HPAT="",HDAT=""
  1. F PSODATE=0:0 S PSODATE=$O(^TMP($J,"PSOSPLOG",PSODATE)) Q:'PSODATE!($G(QFLAG)) S (Y,PDAT)=PSODATE D DD^%DT S PSODATEX=Y D HEAD S PAT="" F S PAT=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT)) Q:PAT=""!($G(QFLAG)) D
  1. .F SINRX=0:0 S SINRX=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT,SINRX)) Q:'SINRX!($G(QFLAG)) D
  1. ..S NODE=$G(^PS(52.5,SINRX,0)),PATPTR=+$P(NODE,"^",3)
  1. ..I 'PATPTR Q
  1. ..S PATNAME=$P($G(^DPT(PATPTR,0)),"^") Q:PATNAME=""
  1. ..I $G(PSPRINT),$G(^PS(52.5,SINRX,"P")) Q
  1. ..I $G(PSUSDIV),$G(PSOSITE)'=$P(NODE,"^",6) Q
  1. ..I PAT'=HPAT!(HDAT'=PDAT) W !!?9,"Patient Name: "_$G(PATNAME) S HPAT=PAT,PDAT=HDAT
  1. ..D:($Y+4)>IOSL HEAD Q:$G(QFLAG)
  1. ..S PSOINRX=+$P($G(NODE),"^")
  1. ..W !,$P($G(^PSRX(+$G(NODE),0)),"^")
  1. ..W ?13,$P($G(^PSDRUG(+$P($G(^PSRX(PSOINRX,0)),"^",6),0)),"^")
  1. ..K PSOMW D
  1. ...I $P(NODE,"^",5) S PSOMW=$P($G(^PSRX(+$G(NODE),"P",$P(NODE,"^",5),0)),"^",2) Q
  1. ...I $P(NODE,"^",13)!($O(^PSRX(+$G(NODE),1,0))) D Q
  1. ....I $P(NODE,"^",13) S PSOMW=$P($G(^PSRX(+$G(NODE),1,$P(NODE,"^",13),0)),"^",2) Q
  1. ....F PP=0:0 S PP=$O(^PSRX(+$G(NODE),1,PP)) Q:'PP S PSOMW=$P($G(^PSRX(+$G(NODE),1,PP,0)),"^",2)
  1. ...S PSOMW=$P($G(^PSRX(+$G(NODE),0)),"^",11)
  1. ..W ?54,$G(PSOMW)
  1. ..S PSOPRINT=$S($G(^PS(52.5,SINRX,"P")):"YES",1:"NO")
  1. ..W ?56,PSOPRINT
  1. ..I PSOPRINT="NO" S PSOBAD="" D CHKBAD I PSOBAD'="" W ?62,PSOBAD
  1. ..I $G(PSOSCMOP),$P(NODE,"^",7)'="" D
  1. ...W ?64,$S($P(NODE,"^",7)="Q":"QUEUED/TRANS",$P(NODE,"^",7)="X":"TRANS/COMPLETE",$P(NODE,"^",7)="L":"LOADING/TRANS",$P(NODE,"^",7)="P":"PRINTED/LOCAL",1:"")
  1. I $E(IOST)'="P",'$G(QFLAG) W ! K DIR S DIR(0)="E" D ^DIR K DIR
  1. W !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
  1. W !,"** END OF REPORT **"
  1. D ^%ZISC G EXIT
  1. I $E(IOST)'="P",PAGE K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S QFLAG=1 Q
  1. W @IOF W !?22,"RX SUSPENSE LIST "_$S($G(PSODATEX)'="":"FOR ",1:"")_$G(PSODATEX) W ?68,"PAGE: ",$G(PAGE) W !,"RX #",?13,"DRUG",?53,"MW",?56,"PRNT B/D/F",?66,$S($G(PSOSCMOP):"CMOP STATUS",1:"") W !,LINE S PAGE=PAGE+1
  1. Q
  1. BIG ;
  1. N PSOPRINT
  1. I '$D(^TMP($J,"PSOSPLOG")) D HEADB W !!,"NO RECORDS TO PRINT",! D:$E(IOST)="C" D ^%ZISC G EXIT
  1. .K DIR S DIR(0)="E" D ^DIR K DIR
  1. F PSODATE=0:0 S PSODATE=$O(^TMP($J,"PSOSPLOG",PSODATE)) Q:'PSODATE!($G(QFLAG)) S Y=PSODATE D DD^%DT S PSODATEX=Y D:PAGE=1 HEADB D HEADND S PAT="" F S PAT=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT)) Q:PAT=""!($G(QFLAG)) D
  1. .F SINRX=0:0 S SINRX=$O(^TMP($J,"PSOSPLOG",PSODATE,PAT,SINRX)) Q:'SINRX!($G(QFLAG)) D
  1. ..S NODE=$G(^PS(52.5,SINRX,0)),PATPTR=+$P(NODE,"^",3)
  1. ..I 'PATPTR Q
  1. ..S PATNAME=$P($G(^DPT(PATPTR,0)),"^") Q:PATNAME=""
  1. ..I $G(PSPRINT),$G(^PS(52.5,SINRX,"P")) Q
  1. ..I $G(PSUSDIV),$G(PSOSITE)'=$P(NODE,"^",6) Q
  1. ..D:($Y+4)>IOSL HEADB Q:$G(QFLAG)
  1. ..S PSOINRX=+$P($G(NODE),"^")
  1. ..W !,$P($G(^PSRX(+$G(NODE),0)),"^")
  1. ..W ?13,$G(PATNAME)
  1. ..W ?45,$P($G(^PSDRUG(+$P($G(^PSRX(PSOINRX,0)),"^",6),0)),"^")
  1. ..K PSOMW D
  1. ...I $P(NODE,"^",5) S PSOMW=$P($G(^PSRX(+$G(NODE),"P",$P(NODE,"^",5),0)),"^",2) Q
  1. ...I $P(NODE,"^",13)!($O(^PSRX(+$G(NODE),1,0))) D Q
  1. ....I $P(NODE,"^",13) S PSOMW=$P($G(^PSRX(+$G(NODE),1,$P(NODE,"^",13),0)),"^",2) Q
  1. ....F PP=0:0 S PP=$O(^PSRX(+$G(NODE),1,PP)) Q:'PP S PSOMW=$P($G(^PSRX(+$G(NODE),1,PP,0)),"^",2)
  1. ...S PSOMW=$P($G(^PSRX(+$G(NODE),0)),"^",11)
  1. ..W ?88,$S($G(PSOMW)="W":"WINDOW",1:"MAIL")
  1. ..S PSOPRINT=$S($G(^PS(52.5,SINRX,"P")):"YES",1:"NO")
  1. ..W ?95,PSOPRINT
  1. ..I PSOPRINT="NO" S PSOBAD="" D CHKBAD I PSOBAD'="" W ?103,PSOBAD
  1. ..I $G(PSOSCMOP),$P(NODE,"^",7)'="" D
  1. ...W ?104,$S($P(NODE,"^",7)="Q":"QUEUED FOR TRANSMISSION",$P(NODE,"^",7)="X":"TRANSMISSION COMPLETED",$P(NODE,"^",7)="L":"LOADING FOR TRANSMISSION",$P(NODE,"^",7)="P":"PRINTED LOCALLY",1:"")
  1. I $E(IOST)'="P",'$G(QFLAG) W ! K DIR S DIR(0)="E" D ^DIR K DIR
  1. W !,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
  1. W !,"** END OF REPORT **"
  1. D ^%ZISC G EXIT
  1. HEADB ;
  1. I $E(IOST)'="P",PAGE K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S QFLAG=1 Q
  1. W @IOF
  1. W !,"RX #",?13,"PATIENT",?45,"DRUG",?88,"TYPE",?93,"PRINTED B/D/F",?108,$S($G(PSOSCMOP):"CMOP STATUS",1:""),?122,"PAGE ",$G(PAGE) W !,LINE S PAGE=PAGE+1
  1. Q
  1. HEADND W !!?40,"RX SUSPENSE LIST "_$S($G(PSODATEX)'="":"FOR ",1:"")_$G(PSODATEX)
  1. Q
  1. ;
  1. CHKADDR ;
  1. N PSOBADR,PSOTEMP
  1. S PSOBADR=$$BADADR^DGUTL3(PSODFN)
  1. I PSOBADR D
  1. .S PSOTEMP=$$CHKTEMP^PSOBAI(PSODFN)
  1. I PSOBADR,'PSOTEMP S (PSOBAI,PSOBDF("B"))=1 Q
  1. Q
  1. ;
  1. FOREIGN ;
  1. N PSOFORGN,DFN
  1. S DFN=PSODFN D ADD^VADPT
  1. S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="" D ;*362
  1. .N PSON
  1. .S PSOBDF("F")=1
  1. .S PSON=$$GET1^DIQ(59,PSOSITE,.01)
  1. .I PSON'["MANILA",PSOFORGN["UNITED STATES" K PSOBDF("F") Q
  1. .I PSON["MANILA",PSOFORGN["PHILIPPINES" K PSOBDF("F")
  1. Q
  1. ;
  1. CHKMAIL ;
  1. N PSOTEMP,MAILEXP,MAILST
  1. S PSOTEMP=$G(^PS(55,PSODFN,0))
  1. S MAILST=$P(PSOTEMP,"^",3)
  1. S MAILEXP=$P(PSOTEMP,"^",5)
  1. I +$G(NODE),$$GET1^DIQ(52,+$G(NODE),100.2,"I")]"" S MAILST=$$GET1^DIQ(52,+$G(NODE),100.2,"I"),MAILEXP="" ;p753
  1. Q:MAILST'=2
  1. I MAILEXP=""!(MAILEXP>DT) S PSOBDF("D")=1
  1. Q
  1. ;
  1. CHKBAD ;
  1. K PSOBDF
  1. S PSODFN=PATPTR
  1. D CHKADDR I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
  1. D CHKMAIL I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
  1. D FOREIGN I $D(PSOBDF) S PSOBAD=$O(PSOBDF("")) K PSOBDF Q
  1. Q
  1. ; CHANGE TO USE FOLLOWING IF WANT TO SEE WHY RX'S DID NOT PRINT PREVIOUSLY (INSTEAD OF CURRENT BAD STATUS)
  1. N RX,SEQ,FILL,ZZ
  1. S RX=+$G(NODE),FILL=$P(NODE,"^",13)
  1. S SEQ=0 F S SEQ=$O(^PSRX(RX,"A",SEQ)) Q:'SEQ S X=$G(^PSRX(RX,"A",SEQ,0)) D
  1. .I $P(X,"^",2)="S" S ZZ=$P(X,"^",4),ZZ=$S(ZZ<6:ZZ,1:ZZ-1) I ZZ=FILL,X["due to" D
  1. ..I X["DO NOT MAIL" S PSOBAD="D" Q
  1. ..I X["BAD ADDRESS" S PSOBAD="B" Q
  1. ..I X["FOREIGN ADDRESS" S PSOBAD="F" Q
  1. Q
  1. ;