- DGPTLMU1 ;ALM/MTC - Utilities used for the List Manager; 9-17-92
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ;
- ;
- 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
- ;
- DGPTLMU1 ;ALM/MTC - Utilities used for the List Manager; 9-17-92
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- +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 ;