DGPTLMU1 ;ALM/MTC - Utilities used for the List Manager; 9-17-92
;;5.3;Registration;;Aug 13, 1993
;
;
EXINT ;-- init routine to call List Manager
N X
K ^TMP("ARCPTF",$J,"LIST")
S X=$P($G(^DGP(45.62,DGTMP,0)),U)
S:X]"" VALMCNT=$$EXPTF(X)
;-- if no entries then delete PTF A/P Template
I X]"",'VALMCNT D
. W !,">>> No entries found... Deleting PTF A/P Template" H 1
. S DIK="^DIBT(",DA=$P(^DGP(45.62,DGTMP,0),U,8) D ^DIK K DA,DIK
. S DIK="^DGP(45.62,",DA=DGTMP D ^DIK K DA,DIK
. S VALMQUIT=""
EXINTQ Q
;
EXQ ;-- exit function call from List Manager
I $D(^TMP("ARCPTF",$J,"LIST","DEL")),$$MAKPER D UPST(DGTMP)
K ^TMP("ARCPTF",$J,"LIST")
D CLEAR^VALM1
Q
;
EXHDR ;-- header function for Editing List.
N X,Y
S VALMHDR(1)="PTF Records Selected from "_$$FTIME^VALM1($P(^DGP(45.62,DGTMP,0),U,10))_" thru "_$$FTIME^VALM1($P(^DGP(45.62,DGTMP,0),U,11))_"."
S VALMHDR(2)="Total Number of PTF records Selected: "_VALMCNT
S Y=$$STATUS^DGPTLMU2(DGTMP)
S VALMHDR(3)="Status: "_$S(Y="P":"PURGED",Y="A":"ARCHIVED",1:"ACTIVE")
Q
;
EXPTF(FNAME) ;-- This function will take the entries in the search
; template FNAME and expand them for display using the List Manager.
; The global that will contain the display items is:
; ^TMP("ARCPTF",$J,"LIST")
; INPUT : FNAME - PTF Archive/Purge File entry
; OUTPUT: Total Number of entries
;
; Format of display string:
; <ptf #> <patient name> <admission date> <discharge date>
N NUMREC,REC,DGX,DGY,X,AREC
S NUMREC=0
;-- get a/p entry
S DGX=$O(^DGP(45.62,"B",FNAME,0)) I 'DGX G EXPTFQ
S REC=$P(^DGP(45.62,DGX,0),U,8) G:'$D(^DIBT(REC)) EXPTFQ
S AREC=$P(^DGP(45.62,DGX,0),U,9)
S DGX=0 F S DGX=$O(^DIBT(REC,1,DGX)) Q:'DGX D
.;-- if records does not exist then clean-up search template
. I '$D(^DGPT(DGX)) K ^DIBT(REC,1,DGX) Q
. S NUMREC=NUMREC+1,X=""
. S X=$$SETSTR^VALM1("*",X,6,1)
. S X=$$SETSTR^VALM1(DGX,X,8,6)
. S X=$$SETSTR^VALM1($P(^DPT(+^DGPT(DGX,0),0),U),X,15,20)
. S X=$$SETSTR^VALM1($$FTIME^VALM1($P(^DGPT(DGX,0),U,2)),X,37,18)
. S DGY=+$G(^DGPT(DGX,70))
. S X=$$SETSTR^VALM1($S(DGY:$$FTIME^VALM1(DGY),1:"<UNKNOWN>"),X,56,18)
. S ^TMP("ARCPTF",$J,"LIST",NUMREC,0)=$$LOWER^VALM1(X)
. S ^TMP("ARCPTF",$J,"LIST","IDX",NUMREC,DGX)=""
. S ^TMP("ARCPTF",$J,"LIST","REC",DGX,NUMREC)=""
. D FLDCTRL^VALM10(NUMREC)
I NUMREC'=AREC S DA=REC,DIE="^DGP(45.62,",DR=".09///^S X=NUMREC" D ^DIE K DIE,DR,DA
EXPTFQ Q NUMREC
;
DELEX ;-- tag entries to delete in the search template.
N DGI,DGJ,Y,X
D SEL^DGPTLMU3
;-- mark entries as deleted from search teplate
S DGI=0 F S DGI=$O(VALMY(DGI)) Q:'DGI I $D(^TMP("ARCPTF",$J,"LIST","REC",DGI)) D
. S ^TMP("ARCPTF",$J,"LIST","DEL",DGI)=""
. S DGJ=$O(^TMP("ARCPTF",$J,"LIST","REC",DGI,0))
. D SAVE^VALM10(DGJ),KILL^VALM10(DGJ)
. S X=^TMP("ARCPTF",$J,"LIST",DGJ,0)
. S X=$$SETSTR^VALM1(" ",X,6,1),^TMP("ARCPTF",$J,"LIST",DGJ,0)=X
. D WRITE^VALM10(DGJ)
S VALMBCK=$S(VALMCC:"",1:"R")
K VALMY
Q
;
ADDEX ;-- if an entry has been un-selected for a/p this function will
; re-activate for the a/p process.
N DGI,DGJ
D SEL^DGPTLMU3
;-- unmark entries as deleted from search teplate
S DGI=0 F S DGI=$O(VALMY(DGI)) Q:'DGI I $D(^TMP("ARCPTF",$J,"LIST","REC",DGI)) D
. K ^TMP("ARCPTF",$J,"LIST","DEL",DGI)
. S DGJ=$O(^TMP("ARCPTF",$J,"LIST","REC",DGI,0))
. D RESTORE^VALM10(DGJ)
. S X=^TMP("ARCPTF",$J,"LIST",DGJ,0)
. S X=$$SETSTR^VALM1("*",X,6,1),^TMP("ARCPTF",$J,"LIST",DGJ,0)=X
. D FLDCTRL^VALM10(DGJ)
. D WRITE^VALM10(DGJ)
S VALMBCK=$S(VALMCC:"",1:"R")
K VALMY
Q
;
MAKPER() ;-- This function will prompt the user if all changes to the
; search template should be made permanent.
; INPUT : - None
; OUTPUT : 1 - Yes, 0 - No
;
N Y
S DIR(0)="Y",DIR("A")="Should I make all changes permanent ",DIR("B")="NO"
D ^DIR
K DIR
Q Y
;
UPST(REC) ;-- This function will update the search template if entries are
; contained in the ^TMP("ATCPTF",$J,"LIST","DEL") global. Lastly,
; the total number of entries will be updated in the PTF A/P
; History file (#45.62)
; INPUT : REC - Entry in file 45.62
N DELREC,I,SRTREC
I '$D(^TMP("ARCPTF",$J,"LIST","DEL")) G UPSTQ
W !,">>> Updating search template." H 1
S DELREC=0,SRTREC=$P(^DGP(45.62,REC,0),U,8)
S I=0 F S I=$O(^TMP("ARCPTF",$J,"LIST","DEL",I)) Q:'I D
. S DELREC=DELREC+1
. K ^DIBT(SRTREC,1,I)
I DELREC=VALMCNT D DELENTRY^DGPTAPSL($P(^DGP(45.62,REC,0),U)) G UPSTQ
I DELREC S DA=REC,DIE="^DGP(45.62,",DR=".09///^S X=VALMCNT-DELREC" D ^DIE K DIE,DR,DA
UPSTQ Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTLMU1 4588 printed Apr 09, 2024@21:56:03 Page 2
DGPTLMU1 ;ALM/MTC - Utilities used for the List Manager; 9-17-92
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
+3 ;
EXINT ;-- init routine to call List Manager
+1 NEW X
+2 KILL ^TMP("ARCPTF",$JOB,"LIST")
+3 SET X=$PIECE($GET(^DGP(45.62,DGTMP,0)),U)
+4 if X]""
SET VALMCNT=$$EXPTF(X)
+5 ;-- if no entries then delete PTF A/P Template
+6 IF X]""
IF 'VALMCNT
Begin DoDot:1
+7 WRITE !,">>> No entries found... Deleting PTF A/P Template"
HANG 1
+8 SET DIK="^DIBT("
SET DA=$PIECE(^DGP(45.62,DGTMP,0),U,8)
DO ^DIK
KILL DA,DIK
+9 SET DIK="^DGP(45.62,"
SET DA=DGTMP
DO ^DIK
KILL DA,DIK
+10 SET VALMQUIT=""
End DoDot:1
EXINTQ QUIT
+1 ;
EXQ ;-- exit function call from List Manager
+1 IF $DATA(^TMP("ARCPTF",$JOB,"LIST","DEL"))
IF $$MAKPER
DO UPST(DGTMP)
+2 KILL ^TMP("ARCPTF",$JOB,"LIST")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
EXHDR ;-- header function for Editing List.
+1 NEW X,Y
+2 SET VALMHDR(1)="PTF Records Selected from "_$$FTIME^VALM1($PIECE(^DGP(45.62,DGTMP,0),U,10))_" thru "_$$FTIME^VALM1($PIECE(^DGP(45.62,DGTMP,0),U,11))_"."
+3 SET VALMHDR(2)="Total Number of PTF records Selected: "_VALMCNT
+4 SET Y=$$STATUS^DGPTLMU2(DGTMP)
+5 SET VALMHDR(3)="Status: "_$SELECT(Y="P":"PURGED",Y="A":"ARCHIVED",1:"ACTIVE")
+6 QUIT
+7 ;
EXPTF(FNAME) ;-- This function will take the entries in the search
+1 ; template FNAME and expand them for display using the List Manager.
+2 ; The global that will contain the display items is:
+3 ; ^TMP("ARCPTF",$J,"LIST")
+4 ; INPUT : FNAME - PTF Archive/Purge File entry
+5 ; OUTPUT: Total Number of entries
+6 ;
+7 ; Format of display string:
+8 ; <ptf #> <patient name> <admission date> <discharge date>
+9 NEW NUMREC,REC,DGX,DGY,X,AREC
+10 SET NUMREC=0
+11 ;-- get a/p entry
+12 SET DGX=$ORDER(^DGP(45.62,"B",FNAME,0))
IF 'DGX
GOTO EXPTFQ
+13 SET REC=$PIECE(^DGP(45.62,DGX,0),U,8)
if '$DATA(^DIBT(REC))
GOTO EXPTFQ
+14 SET AREC=$PIECE(^DGP(45.62,DGX,0),U,9)
+15 SET DGX=0
FOR
SET DGX=$ORDER(^DIBT(REC,1,DGX))
if 'DGX
QUIT
Begin DoDot:1
+16 ;-- if records does not exist then clean-up search template
+17 IF '$DATA(^DGPT(DGX))
KILL ^DIBT(REC,1,DGX)
QUIT
+18 SET NUMREC=NUMREC+1
SET X=""
+19 SET X=$$SETSTR^VALM1("*",X,6,1)
+20 SET X=$$SETSTR^VALM1(DGX,X,8,6)
+21 SET X=$$SETSTR^VALM1($PIECE(^DPT(+^DGPT(DGX,0),0),U),X,15,20)
+22 SET X=$$SETSTR^VALM1($$FTIME^VALM1($PIECE(^DGPT(DGX,0),U,2)),X,37,18)
+23 SET DGY=+$GET(^DGPT(DGX,70))
+24 SET X=$$SETSTR^VALM1($SELECT(DGY:$$FTIME^VALM1(DGY),1:"<UNKNOWN>"),X,56,18)
+25 SET ^TMP("ARCPTF",$JOB,"LIST",NUMREC,0)=$$LOWER^VALM1(X)
+26 SET ^TMP("ARCPTF",$JOB,"LIST","IDX",NUMREC,DGX)=""
+27 SET ^TMP("ARCPTF",$JOB,"LIST","REC",DGX,NUMREC)=""
+28 DO FLDCTRL^VALM10(NUMREC)
End DoDot:1
+29 IF NUMREC'=AREC
SET DA=REC
SET DIE="^DGP(45.62,"
SET DR=".09///^S X=NUMREC"
DO ^DIE
KILL DIE,DR,DA
EXPTFQ QUIT NUMREC
+1 ;
DELEX ;-- tag entries to delete in the search template.
+1 NEW DGI,DGJ,Y,X
+2 DO SEL^DGPTLMU3
+3 ;-- mark entries as deleted from search teplate
+4 SET DGI=0
FOR
SET DGI=$ORDER(VALMY(DGI))
if 'DGI
QUIT
IF $DATA(^TMP("ARCPTF",$JOB,"LIST","REC",DGI))
Begin DoDot:1
+5 SET ^TMP("ARCPTF",$JOB,"LIST","DEL",DGI)=""
+6 SET DGJ=$ORDER(^TMP("ARCPTF",$JOB,"LIST","REC",DGI,0))
+7 DO SAVE^VALM10(DGJ)
DO KILL^VALM10(DGJ)
+8 SET X=^TMP("ARCPTF",$JOB,"LIST",DGJ,0)
+9 SET X=$$SETSTR^VALM1(" ",X,6,1)
SET ^TMP("ARCPTF",$JOB,"LIST",DGJ,0)=X
+10 DO WRITE^VALM10(DGJ)
End DoDot:1
+11 SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+12 KILL VALMY
+13 QUIT
+14 ;
ADDEX ;-- if an entry has been un-selected for a/p this function will
+1 ; re-activate for the a/p process.
+2 NEW DGI,DGJ
+3 DO SEL^DGPTLMU3
+4 ;-- unmark entries as deleted from search teplate
+5 SET DGI=0
FOR
SET DGI=$ORDER(VALMY(DGI))
if 'DGI
QUIT
IF $DATA(^TMP("ARCPTF",$JOB,"LIST","REC",DGI))
Begin DoDot:1
+6 KILL ^TMP("ARCPTF",$JOB,"LIST","DEL",DGI)
+7 SET DGJ=$ORDER(^TMP("ARCPTF",$JOB,"LIST","REC",DGI,0))
+8 DO RESTORE^VALM10(DGJ)
+9 SET X=^TMP("ARCPTF",$JOB,"LIST",DGJ,0)
+10 SET X=$$SETSTR^VALM1("*",X,6,1)
SET ^TMP("ARCPTF",$JOB,"LIST",DGJ,0)=X
+11 DO FLDCTRL^VALM10(DGJ)
+12 DO WRITE^VALM10(DGJ)
End DoDot:1
+13 SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+14 KILL VALMY
+15 QUIT
+16 ;
MAKPER() ;-- This function will prompt the user if all changes to the
+1 ; search template should be made permanent.
+2 ; INPUT : - None
+3 ; OUTPUT : 1 - Yes, 0 - No
+4 ;
+5 NEW Y
+6 SET DIR(0)="Y"
SET DIR("A")="Should I make all changes permanent "
SET DIR("B")="NO"
+7 DO ^DIR
+8 KILL DIR
+9 QUIT Y
+10 ;
UPST(REC) ;-- This function will update the search template if entries are
+1 ; contained in the ^TMP("ATCPTF",$J,"LIST","DEL") global. Lastly,
+2 ; the total number of entries will be updated in the PTF A/P
+3 ; History file (#45.62)
+4 ; INPUT : REC - Entry in file 45.62
+5 NEW DELREC,I,SRTREC
+6 IF '$DATA(^TMP("ARCPTF",$JOB,"LIST","DEL"))
GOTO UPSTQ
+7 WRITE !,">>> Updating search template."
HANG 1
+8 SET DELREC=0
SET SRTREC=$PIECE(^DGP(45.62,REC,0),U,8)
+9 SET I=0
FOR
SET I=$ORDER(^TMP("ARCPTF",$JOB,"LIST","DEL",I))
if 'I
QUIT
Begin DoDot:1
+10 SET DELREC=DELREC+1
+11 KILL ^DIBT(SRTREC,1,I)
End DoDot:1
+12 IF DELREC=VALMCNT
DO DELENTRY^DGPTAPSL($PIECE(^DGP(45.62,REC,0),U))
GOTO UPSTQ
+13 IF DELREC
SET DA=REC
SET DIE="^DGP(45.62,"
SET DR=".09///^S X=VALMCNT-DELREC"
DO ^DIE
KILL DIE,DR,DA
UPSTQ QUIT
+1 ;
