PXVDIS ;BPFO/LMT - Imm Disclosure Report ;06/22/16 17:04
;;1.0;PCE PATIENT CARE ENCOUNTER;**216**;Aug 12, 1996;Build 11
;
;
MAIN ;
N PXAG,PXEXIT,PXFROM,PXPROMPT,PXPT,PXTO
;
S PXEXIT=$$PROMPTDT(.PXFROM,.PXTO)
I PXEXIT Q
;
; - Selection of AGENCY to print on the Report
S PXPROMPT(1)="AGENCIES"
S PXPROMPT(2)="AGENCY"
S PXEXIT=$$PROMPT(920.71,.PXPROMPT,.PXAG)
I PXEXIT Q
K PXPROMPT
;
; - Selection of PATIENTS to print on the Report
S PXPROMPT(1)="PATIENTS"
S PXPROMPT(2)="PATIENT"
S PXEXIT=$$PROMPT(2,.PXPROMPT,.PXPT)
I PXEXIT Q
;
D ASKDVC
;
Q
;
PROMPTDT(PXFROM,PXTO) ;
;
N %DT,DTOUT,X,Y
;
; - Ask for FROM DATE
S %DT(0)=-DT
S %DT="AEP"
S %DT("A")=" BEGIN DATE: "
W !
D ^%DT
I Y<0!($D(DTOUT)) Q 1
S PXFROM=$P(Y,".",1)
;
; - Ask for TO DATE
K %DT,X,Y
S %DT(0)=PXFROM
S %DT="AEP"
S %DT("B")="TODAY"
S %DT("A")=" END DATE: "
W !
D ^%DT
I Y<0!($D(DTOUT)) Q 1
S PXTO=$P(Y,".",1)+.24
;
Q 0
;
PROMPT(PXFILE,PXPROMPT,PXRESP) ;
;
N DIC,DLAYGO,DTOUT,DUOUT,X,Y
;
W !!,?5,"You may select a single or multiple "_PXPROMPT(1)_","
W !,?5,"or enter ^ALL to select all "_PXPROMPT(1)_".",!
;
S DIC=PXFILE
S DIC(0)="QEAM"
S DIC("A")=" Select "_PXPROMPT(2)_": "
F D ^DIC Q:Y<0 S PXRESP(+Y)="" S DIC("A")=" Another "_PXPROMPT(2)_": "
I X="^ALL" S PXRESP="ALL" Q 0
I $D(DUOUT)!($D(DTOUT)) Q 1
I '$O(PXRESP(0)) Q 1
Q 0
;
MAIN2 ;
;
N PXI,PXINDEX
;
D CLEAN
;
S PXINDEX="ADA"
I $G(PXPT)'="ALL" S PXINDEX="ADP"
I PXINDEX="ADA" D
. I $G(PXAG)="ALL" D FIND(PXINDEX,"",.PXFROM,.PXTO,.PXAG,.PXPT) Q
. S PXI=0
. F S PXI=$O(PXAG(PXI)) Q:'PXI D
. . D FIND(PXINDEX,PXI,.PXFROM,.PXTO,.PXAG,.PXPT)
I PXINDEX="ADP" D
. I $G(PXPT)="ALL" D FIND(PXINDEX,"",.PXFROM,.PXTO,.PXAG,.PXPT) Q
. S PXI=0
. F S PXI=$O(PXPT(PXI)) Q:'PXI D
. . D FIND(PXINDEX,PXI,.PXFROM,.PXTO,.PXAG,.PXPT)
;
D PRINT
D CLEAN
Q
;
FIND(PXINDEX,PXSUB,PXFROM,PXTO,PXAG,PXPT) ;
N PXGBL
I PXSUB="" S PXGBL=$NA(^AUPNVIMM(PXINDEX,(PXFROM-.00001)))
I PXSUB'="" S PXGBL=$NA(^AUPNVIMM(PXINDEX,(PXFROM-.00001),PXSUB))
D FIND2(PXGBL,PXINDEX,.PXSUB,.PXFROM,.PXTO,.PXAG,.PXPT)
I PXSUB="" S PXGBL=$NA(^AUPDVIMM(PXINDEX,(PXFROM-.00001)))
I PXSUB'="" S PXGBL=$NA(^AUPDVIMM(PXINDEX,(PXFROM-.00001),PXSUB))
D FIND2(PXGBL,PXINDEX,.PXSUB,.PXFROM,.PXTO,.PXAG,.PXPT)
Q
;
FIND2(PXGBL,PXINDEX,PXSUB,PXFROM,PXTO,PXAG,PXPT) ;
;
N DFN,PXADMINDT,PXAGENCY,PXDISCDT,PXDISIEN,PXGBLRT,PXIMMUN,PXNODE,PXPATNM,PXVIMMIEN,PXVISIT,VADM
;
S PXGBLRT=$S(PXGBL["AUPNVIMM":"^AUPNVIMM",1:"^AUPDVIMM")
F S PXGBL=$Q(@PXGBL) Q:PXGBL="" Q:($QS(PXGBL,1)'=PXINDEX)!($QS(PXGBL,2)>PXTO)!((PXSUB'="")&($QS(PXGBL,3)'=PXSUB)) D
. S PXDISCDT=$QS(PXGBL,2)
. S PXVIMMIEN=$QS(PXGBL,4)
. S PXDISIEN=$QS(PXGBL,5)
. S PXAGENCY=$P($G(@PXGBLRT@(PXVIMMIEN,820,PXDISIEN,0)),U,1)
. I $G(PXAG)'="ALL",'$D(PXAG(PXAGENCY)) Q
. S PXAGENCY=$E($P($G(^PXV(920.71,+PXAGENCY,0)),U,1),1,35)
. ;
. S PXNODE=$G(@PXGBLRT@(PXVIMMIEN,0))
. S DFN=$P(PXNODE,U,2)
. I $G(PXPT)'="ALL",'$D(PXPT(DFN)) Q
. D KVA^VADPT
. D DEM^VADPT
. S PXPATNM=$E(VADM(1),1,24)
. S PXPATNM=PXPATNM_"("_$E($P(VADM(2),U),6,9)_")"
. D KVA^VADPT
. S PXIMMUN=$P(PXNODE,U,1)
. S PXADMINDT=$P($G(@PXGBLRT@(PXVIMMIEN,12)),U,1)
. I PXADMINDT="" D
. . S PXVISIT=$P(PXNODE,U,3)
. . S PXADMINDT=$P($G(^AUPNVSIT(PXVISIT,0)),U,1)
. S ^TMP("PXVDIS",$J,PXDISCDT,PXAGENCY,PXPATNM,PXVIMMIEN)=PXIMMUN_U_PXADMINDT
;
Q
;
PRINT ;
;
N PXAGENCY,PXDISCDT,PXEND,PXGBL,PXIMM,PXLINE,PXNODE,PXNOW,PXNUMLN,PXPAGE,PXPATNM,PXVIMM
;
S PXEND=0
S PXNOW=$$NOW^XLFDT
S PXLINE=$$REPEAT^XLFSTR("-",131)
S PXPAGE=0
S PXNUMLN=$S($E(IOST,1,2)="C-":5,1:2)
;
D PRINTHDR(PXNOW,.PXPAGE,PXLINE)
;
S PXGBL=$NA(^TMP("PXVDIS",$J))
F S PXGBL=$Q(@PXGBL) Q:PXGBL=""!($G(PXEND)) Q:($QS(PXGBL,1)'="PXVDIS")!($QS(PXGBL,2)'=$J) D
. S PXDISCDT=$QS(PXGBL,3)
. S PXAGENCY=$QS(PXGBL,4)
. S PXPATNM=$QS(PXGBL,5)
. S PXVIMM=$QS(PXGBL,6)
. S PXNODE=$G(@PXGBL)
. S PXIMM=$P(PXNODE,U,1)
. W !,$$FMTE^XLFDT(PXDISCDT,"2M"),?16,PXAGENCY,?53,PXPATNM,?85,$E($P($G(^AUTTIMM(+PXIMM,0)),U,1),1,30)
. W ?117,$$FMTE^XLFDT($P(PXNODE,U,2),"2M")
. I $Y+PXNUMLN>IOSL D PRINTHDR(PXNOW,.PXPAGE,PXLINE)
I '$G(PXEND) D PAUSE
Q
;
PRINTHDR(PXNOW,PXPAGE,PXLINE) ;
;
I PXPAGE>0 D PAUSE
I $G(PXEND) Q
W @IOF
S PXPAGE=PXPAGE+1
W ?13,"ACCOUNTING OF DISCLOSURES REPORT"
W !,?13,"Report printed on: ",$$FMTE^XLFDT(PXNOW),?88,"Page: ",PXPAGE
W !,?13,"Date Range: "_$$FMTE^XLFDT(PXFROM,2)_" - "_$$FMTE^XLFDT($P(PXTO,".",1),2)
W ?48,"Agency(ies): "_$S($G(PXAG)="ALL":"ALL",$O(PXAG($O(PXAG(0)))):"Multiple",1:$E($P($G(^PXV(920.71,+$O(PXAG(0)),0)),U,1),1,25))
W ?88,"Patient(s): "_$S($G(PXPT)="ALL":"ALL",$O(PXPT($O(PXPT(0)))):"Multiple",1:$$GET1^DIQ(2,+$O(PXPT(0)),.01))
W !!,"Info Disclosed: Name, DOB, Sex, Race, Ethnicity, Mother Maiden Name, Place of Birth, Address, Phone Number, NOK, Immunization Data"
W !,"Purpose: Record and track a complete immunization history for the purpose of public health care coordination"
W !!,"DT DISCLOSED",?16,"DISCLOSED TO",?53,"PATIENT",?85,"IMMUNIZATION",?117,"ADMIN DT"
W !,PXLINE
Q
;
PAUSE ;
N DIR,DIRUT,X,Y
I $E(IOST,1,2)'="C-" Q
W !
S DIR(0)="E" D ^DIR
I $D(DIRUT) S PXEND=1
Q
;
CLEAN ;
K ^TMP("PXVDIS",$J)
Q
;
ASKDVC ;Prompts user for device of output (allows queuing)
N PXVAR,ZTSK
W !!!,"This report is designed for a 132 column format (compressed).",!
S PXVAR("PXFROM")=""
S PXVAR("PXTO")=""
S PXVAR("PXAG(")=""
S PXVAR("PXPT(")=""
D EN^XUTMDEVQ("MAIN2^PXVDIS","Print Immunization Disclosure Report",.PXVAR,"QM",1)
W:$D(ZTSK) !,"Report Queued to Print ("_ZTSK_").",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVDIS 5754 printed Oct 16, 2024@18:32:19 Page 2
PXVDIS ;BPFO/LMT - Imm Disclosure Report ;06/22/16 17:04
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**216**;Aug 12, 1996;Build 11
+2 ;
+3 ;
MAIN ;
+1 NEW PXAG,PXEXIT,PXFROM,PXPROMPT,PXPT,PXTO
+2 ;
+3 SET PXEXIT=$$PROMPTDT(.PXFROM,.PXTO)
+4 IF PXEXIT
QUIT
+5 ;
+6 ; - Selection of AGENCY to print on the Report
+7 SET PXPROMPT(1)="AGENCIES"
+8 SET PXPROMPT(2)="AGENCY"
+9 SET PXEXIT=$$PROMPT(920.71,.PXPROMPT,.PXAG)
+10 IF PXEXIT
QUIT
+11 KILL PXPROMPT
+12 ;
+13 ; - Selection of PATIENTS to print on the Report
+14 SET PXPROMPT(1)="PATIENTS"
+15 SET PXPROMPT(2)="PATIENT"
+16 SET PXEXIT=$$PROMPT(2,.PXPROMPT,.PXPT)
+17 IF PXEXIT
QUIT
+18 ;
+19 DO ASKDVC
+20 ;
+21 QUIT
+22 ;
PROMPTDT(PXFROM,PXTO) ;
+1 ;
+2 NEW %DT,DTOUT,X,Y
+3 ;
+4 ; - Ask for FROM DATE
+5 SET %DT(0)=-DT
+6 SET %DT="AEP"
+7 SET %DT("A")=" BEGIN DATE: "
+8 WRITE !
+9 DO ^%DT
+10 IF Y<0!($DATA(DTOUT))
QUIT 1
+11 SET PXFROM=$PIECE(Y,".",1)
+12 ;
+13 ; - Ask for TO DATE
+14 KILL %DT,X,Y
+15 SET %DT(0)=PXFROM
+16 SET %DT="AEP"
+17 SET %DT("B")="TODAY"
+18 SET %DT("A")=" END DATE: "
+19 WRITE !
+20 DO ^%DT
+21 IF Y<0!($DATA(DTOUT))
QUIT 1
+22 SET PXTO=$PIECE(Y,".",1)+.24
+23 ;
+24 QUIT 0
+25 ;
PROMPT(PXFILE,PXPROMPT,PXRESP) ;
+1 ;
+2 NEW DIC,DLAYGO,DTOUT,DUOUT,X,Y
+3 ;
+4 WRITE !!,?5,"You may select a single or multiple "_PXPROMPT(1)_","
+5 WRITE !,?5,"or enter ^ALL to select all "_PXPROMPT(1)_".",!
+6 ;
+7 SET DIC=PXFILE
+8 SET DIC(0)="QEAM"
+9 SET DIC("A")=" Select "_PXPROMPT(2)_": "
+10 FOR
DO ^DIC
if Y<0
QUIT
SET PXRESP(+Y)=""
SET DIC("A")=" Another "_PXPROMPT(2)_": "
+11 IF X="^ALL"
SET PXRESP="ALL"
QUIT 0
+12 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT 1
+13 IF '$ORDER(PXRESP(0))
QUIT 1
+14 QUIT 0
+15 ;
MAIN2 ;
+1 ;
+2 NEW PXI,PXINDEX
+3 ;
+4 DO CLEAN
+5 ;
+6 SET PXINDEX="ADA"
+7 IF $GET(PXPT)'="ALL"
SET PXINDEX="ADP"
+8 IF PXINDEX="ADA"
Begin DoDot:1
+9 IF $GET(PXAG)="ALL"
DO FIND(PXINDEX,"",.PXFROM,.PXTO,.PXAG,.PXPT)
QUIT
+10 SET PXI=0
+11 FOR
SET PXI=$ORDER(PXAG(PXI))
if 'PXI
QUIT
Begin DoDot:2
+12 DO FIND(PXINDEX,PXI,.PXFROM,.PXTO,.PXAG,.PXPT)
End DoDot:2
End DoDot:1
+13 IF PXINDEX="ADP"
Begin DoDot:1
+14 IF $GET(PXPT)="ALL"
DO FIND(PXINDEX,"",.PXFROM,.PXTO,.PXAG,.PXPT)
QUIT
+15 SET PXI=0
+16 FOR
SET PXI=$ORDER(PXPT(PXI))
if 'PXI
QUIT
Begin DoDot:2
+17 DO FIND(PXINDEX,PXI,.PXFROM,.PXTO,.PXAG,.PXPT)
End DoDot:2
End DoDot:1
+18 ;
+19 DO PRINT
+20 DO CLEAN
+21 QUIT
+22 ;
FIND(PXINDEX,PXSUB,PXFROM,PXTO,PXAG,PXPT) ;
+1 NEW PXGBL
+2 IF PXSUB=""
SET PXGBL=$NAME(^AUPNVIMM(PXINDEX,(PXFROM-.00001)))
+3 IF PXSUB'=""
SET PXGBL=$NAME(^AUPNVIMM(PXINDEX,(PXFROM-.00001),PXSUB))
+4 DO FIND2(PXGBL,PXINDEX,.PXSUB,.PXFROM,.PXTO,.PXAG,.PXPT)
+5 IF PXSUB=""
SET PXGBL=$NAME(^AUPDVIMM(PXINDEX,(PXFROM-.00001)))
+6 IF PXSUB'=""
SET PXGBL=$NAME(^AUPDVIMM(PXINDEX,(PXFROM-.00001),PXSUB))
+7 DO FIND2(PXGBL,PXINDEX,.PXSUB,.PXFROM,.PXTO,.PXAG,.PXPT)
+8 QUIT
+9 ;
FIND2(PXGBL,PXINDEX,PXSUB,PXFROM,PXTO,PXAG,PXPT) ;
+1 ;
+2 NEW DFN,PXADMINDT,PXAGENCY,PXDISCDT,PXDISIEN,PXGBLRT,PXIMMUN,PXNODE,PXPATNM,PXVIMMIEN,PXVISIT,VADM
+3 ;
+4 SET PXGBLRT=$SELECT(PXGBL["AUPNVIMM":"^AUPNVIMM",1:"^AUPDVIMM")
+5 FOR
SET PXGBL=$QUERY(@PXGBL)
if PXGBL=""
QUIT
if ($QSUBSCRIPT(PXGBL,1)'=PXINDEX)!($QSUBSCRIPT(PXGBL,2)>PXTO)!((PXSUB'="")&($QSUBSCRIPT(PXGBL,3)'=PXSUB))
QUIT
Begin DoDot:1
+6 SET PXDISCDT=$QSUBSCRIPT(PXGBL,2)
+7 SET PXVIMMIEN=$QSUBSCRIPT(PXGBL,4)
+8 SET PXDISIEN=$QSUBSCRIPT(PXGBL,5)
+9 SET PXAGENCY=$PIECE($GET(@PXGBLRT@(PXVIMMIEN,820,PXDISIEN,0)),U,1)
+10 IF $GET(PXAG)'="ALL"
IF '$DATA(PXAG(PXAGENCY))
QUIT
+11 SET PXAGENCY=$EXTRACT($PIECE($GET(^PXV(920.71,+PXAGENCY,0)),U,1),1,35)
+12 ;
+13 SET PXNODE=$GET(@PXGBLRT@(PXVIMMIEN,0))
+14 SET DFN=$PIECE(PXNODE,U,2)
+15 IF $GET(PXPT)'="ALL"
IF '$DATA(PXPT(DFN))
QUIT
+16 DO KVA^VADPT
+17 DO DEM^VADPT
+18 SET PXPATNM=$EXTRACT(VADM(1),1,24)
+19 SET PXPATNM=PXPATNM_"("_$EXTRACT($PIECE(VADM(2),U),6,9)_")"
+20 DO KVA^VADPT
+21 SET PXIMMUN=$PIECE(PXNODE,U,1)
+22 SET PXADMINDT=$PIECE($GET(@PXGBLRT@(PXVIMMIEN,12)),U,1)
+23 IF PXADMINDT=""
Begin DoDot:2
+24 SET PXVISIT=$PIECE(PXNODE,U,3)
+25 SET PXADMINDT=$PIECE($GET(^AUPNVSIT(PXVISIT,0)),U,1)
End DoDot:2
+26 SET ^TMP("PXVDIS",$JOB,PXDISCDT,PXAGENCY,PXPATNM,PXVIMMIEN)=PXIMMUN_U_PXADMINDT
End DoDot:1
+27 ;
+28 QUIT
+29 ;
PRINT ;
+1 ;
+2 NEW PXAGENCY,PXDISCDT,PXEND,PXGBL,PXIMM,PXLINE,PXNODE,PXNOW,PXNUMLN,PXPAGE,PXPATNM,PXVIMM
+3 ;
+4 SET PXEND=0
+5 SET PXNOW=$$NOW^XLFDT
+6 SET PXLINE=$$REPEAT^XLFSTR("-",131)
+7 SET PXPAGE=0
+8 SET PXNUMLN=$SELECT($EXTRACT(IOST,1,2)="C-":5,1:2)
+9 ;
+10 DO PRINTHDR(PXNOW,.PXPAGE,PXLINE)
+11 ;
+12 SET PXGBL=$NAME(^TMP("PXVDIS",$JOB))
+13 FOR
SET PXGBL=$QUERY(@PXGBL)
if PXGBL=""!($GET(PXEND))
QUIT
if ($QSUBSCRIPT(PXGBL,1)'="PXVDIS")!($QSUBSCRIPT(PXGBL,2)'=$JOB)
QUIT
Begin DoDot:1
+14 SET PXDISCDT=$QSUBSCRIPT(PXGBL,3)
+15 SET PXAGENCY=$QSUBSCRIPT(PXGBL,4)
+16 SET PXPATNM=$QSUBSCRIPT(PXGBL,5)
+17 SET PXVIMM=$QSUBSCRIPT(PXGBL,6)
+18 SET PXNODE=$GET(@PXGBL)
+19 SET PXIMM=$PIECE(PXNODE,U,1)
+20 WRITE !,$$FMTE^XLFDT(PXDISCDT,"2M"),?16,PXAGENCY,?53,PXPATNM,?85,$EXTRACT($PIECE($GET(^AUTTIMM(+PXIMM,0)),U,1),1,30)
+21 WRITE ?117,$$FMTE^XLFDT($PIECE(PXNODE,U,2),"2M")
+22 IF $Y+PXNUMLN>IOSL
DO PRINTHDR(PXNOW,.PXPAGE,PXLINE)
End DoDot:1
+23 IF '$GET(PXEND)
DO PAUSE
+24 QUIT
+25 ;
PRINTHDR(PXNOW,PXPAGE,PXLINE) ;
+1 ;
+2 IF PXPAGE>0
DO PAUSE
+3 IF $GET(PXEND)
QUIT
+4 WRITE @IOF
+5 SET PXPAGE=PXPAGE+1
+6 WRITE ?13,"ACCOUNTING OF DISCLOSURES REPORT"
+7 WRITE !,?13,"Report printed on: ",$$FMTE^XLFDT(PXNOW),?88,"Page: ",PXPAGE
+8 WRITE !,?13,"Date Range: "_$$FMTE^XLFDT(PXFROM,2)_" - "_$$FMTE^XLFDT($PIECE(PXTO,".",1),2)
+9 WRITE ?48,"Agency(ies): "_$SELECT($GET(PXAG)="ALL":"ALL",$ORDER(PXAG($ORDER(PXAG(0)))):"Multiple",1:$EXTRACT($PIECE($GET(^PXV(920.71,+$ORDER(PXAG(0)),0)),U,1),1,25))
+10 WRITE ?88,"Patient(s): "_$SELECT($GET(PXPT)="ALL":"ALL",$ORDER(PXPT($ORDER(PXPT(0)))):"Multiple",1:$$GET1^DIQ(2,+$ORDER(PXPT(0)),.01))
+11 WRITE !!,"Info Disclosed: Name, DOB, Sex, Race, Ethnicity, Mother Maiden Name, Place of Birth, Address, Phone Number, NOK, Immunization Data"
+12 WRITE !,"Purpose: Record and track a complete immunization history for the purpose of public health care coordination"
+13 WRITE !!,"DT DISCLOSED",?16,"DISCLOSED TO",?53,"PATIENT",?85,"IMMUNIZATION",?117,"ADMIN DT"
+14 WRITE !,PXLINE
+15 QUIT
+16 ;
PAUSE ;
+1 NEW DIR,DIRUT,X,Y
+2 IF $EXTRACT(IOST,1,2)'="C-"
QUIT
+3 WRITE !
+4 SET DIR(0)="E"
DO ^DIR
+5 IF $DATA(DIRUT)
SET PXEND=1
+6 QUIT
+7 ;
CLEAN ;
+1 KILL ^TMP("PXVDIS",$JOB)
+2 QUIT
+3 ;
ASKDVC ;Prompts user for device of output (allows queuing)
+1 NEW PXVAR,ZTSK
+2 WRITE !!!,"This report is designed for a 132 column format (compressed).",!
+3 SET PXVAR("PXFROM")=""
+4 SET PXVAR("PXTO")=""
+5 SET PXVAR("PXAG(")=""
+6 SET PXVAR("PXPT(")=""
+7 DO EN^XUTMDEVQ("MAIN2^PXVDIS","Print Immunization Disclosure Report",.PXVAR,"QM",1)
+8 if $DATA(ZTSK)
WRITE !,"Report Queued to Print ("_ZTSK_").",!
+9 QUIT
