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

APCLVL4.m

Go to the documentation of this file. 
  1. APCLVL4 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 25-JUN-1996 ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;; ;
  1. EN ; -- main entry point for APCL VGEN SELECT ITEMS
  1.  I $G(APCLLMOR)="" S APCLLMOR="P"
  1.  I APCLLMOR="G" D ^APCLVL5 Q
  1.  K APCLCSEL
  1.  D EN^VALM("APCL VGEN SELECT ITEMS")
  1.  D CLEAR^VALM1
  1.  K APCLDISP,APCLSEL,APCLLIST,C,X,I,K,J,APCLHIGH,APCLCUT,APCLCSEL,APCLCNTL
  1.  K VALMHDR,VALMCNT
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  I $G(APCLCNTL)="" Q
  1.  D @("HDR"_APCLCNTL)
  1.  Q
  1. HDRS ;
  1.  S VALMHDR(1)="                        "_$G(IORVON)_$S(APCLPTVS="V":"VISIT ",1:"PATIENT ")_"Selection Menu"_$G(IORVOFF)
  1.  S VALMHDR(2)=$S(APCLPTVS="V":"Visits",1:"Patients")_" can be selected based upon any of the following items.  Select"
  1.  S VALMHDR(3)="as many as you wish, in any order or combination.  An (*) asterisk indicates"
  1.  S VALMHDR(4)="items already selected.  To bypass screens and select all "_$S(APCLPTVS="V":"visits",1:"patients")_" hit Q."
  1.  Q
  1.  ;
  1. HDRP ;print selection header
  1.  S VALMHDR(1)="                        "_$G(IORVON)_"PRINT ITEM SELECTION MENU"_$G(IORVOFF)
  1.  S VALMHDR(2)="The following data items can be printed.  Choose the items in the order you"
  1.  S VALMHDR(3)="want them to appear on the printout.  Keep in mind that you have an 80"
  1.  S VALMHDR(4)="column screen available, or a printer with either 80 or 132 column width."
  1.  Q
  1.  ;
  1. HDRR ;sort header
  1.  S VALMHDR(1)=""
  1.  S VALMHDR(2)="                        "_$G(IORVON)_"SORT ITEM SELECTION MENU"_$G(IORVOFF)
  1.  S VALMHDR(3)="The "_$S(APCLPTVS="P":"patients",1:"visits")_" displayed can be SORTED by ONLY ONE of the following items."
  1.  S VALMHDR(4)="If you don't select a sort item, the report will be sorted by "_$S(APCLPTVS="V":"visit date.",1:"patient name.")
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  K APCLDISP,APCLSEL,APCLHIGH,APCLLIST
  1.  I APCLLMOR="P" S APCLXREF="C"
  1.  I APCLLMOR="A" S APCLXREF="B"
  1.  S APCLHIGH=0,X=0 F  S X=$O(^APCLVSTS(APCLXREF,X)) Q:X=""  S Y=$O(^APCLVSTS(APCLXREF,X,"")) I $P(^APCLVSTS(Y,0),U,5)[APCLCNTL,$P(^(0),U,11)[APCLPTVS S APCLHIGH=APCLHIGH+1,APCLSEL(APCLHIGH)=Y
  1.  S APCLCUT=((APCLHIGH/3)+1)\1
  1.  S (C,I)=0,J=1,K=1 F  S I=$O(APCLSEL(I)) Q:I'=+I!($D(APCLDISP(I)))  D
  1.  .S C=C+1,APCLZZ=$$T(I,APCLCNTL),APCLLIST(C,0)=I_")"_$S($D(APCLCSEL(I)):"*",1:" ")_APCLZZ S APCLDISP(I)="",APCLLIST("IDX",C,C)=""
  1.  .S J=I+APCLCUT I $D(APCLSEL(J)),'$D(APCLDISP(J)) S APCLZZ=$$T(J,APCLCNTL),$E(APCLLIST(C,0),28)=J_")"_$S($D(APCLCSEL(J)):"*",1:" ")_APCLZZ S APCLDISP(J)=""
  1.  .S K=J+APCLCUT I $D(APCLSEL(K)),'$D(APCLDISP(K)) S APCLZZ=$$T(K,APCLCNTL),$E(APCLLIST(C,0),55)=K_")"_$S($D(APCLCSEL(K)):"*",1:" ")_APCLZZ S APCLDISP(K)=""
  1.  K APCLDISP
  1.  S VALMCNT=C
  1.  Q
  1.  ;
  1.  ;
  1. ADD ;EP - add an item to the selected list - called from a protocol
  1.  G:APCLCNTL="R" SELECTR
  1.  W ! S DIR(0)="LO^1:"_APCLHIGH,DIR("A")="Which "_$S(APCLPTVS="P":"patient",1:"visit")_" item(s)" D DIRQ^APCLVLS1,^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No items selected." G ADDX
  1.  I $D(DIRUT) W !,"No items selected." G ADDX
  1.  D FULL^VALM1 W:$D(IOF) @IOF
  1.  D @("SELECT"_APCLCNTL)
  1. ADDX ;
  1.  S DIR(0)="EO",DIR("A")="Hit return to continue..." K DA D ^DIR K DIR
  1.  D BACK
  1.  Q
  1. SELECTS ;select screen items
  1.  S APCLANS=Y,APCLC="" F APCLI=1:1 S APCLC=$P(APCLANS,",",APCLI) Q:APCLC=""  S APCLCRIT=APCLSEL(APCLC) D
  1.  .S APCLTEXT=$P(^APCLVSTS(APCLCRIT,0),U)
  1.  .S APCLVAR=$P(^APCLVSTS(APCLCRIT,0),U,6) K ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
  1.  .W !!,APCLC,") ",APCLTEXT," Selection."
  1.  .I $O(^APCLVSTS(APCLCRIT,11,0)) D SELECTST
  1.  .I $P(^APCLVSTS(APCLCRIT,0),U,2)]"" S APCLCNT=0,^APCLVRPT(APCLRPT,11,0)="^9001003.81101PA^0^0" D @($P(^APCLVSTS(APCLCRIT,0),U,2)_"^APCLVL0")
  1.  .I $D(^APCLVRPT(APCLRPT,11,APCLCRIT,11,1)) S APCLCSEL(APCLC)=""
  1.  .Q
  1.  D SHOW^APCLVLS
  1.  Q
  1. SELECTST ;print help text for this item
  1.  W ! NEW X S X=0 F  S X=$O(^APCLVSTS(APCLCRIT,11,X)) Q:X'=+X  W !,^APCLVSTS(APCLCRIT,11,X,0)
  1.  W !
  1.  Q
  1. SELECTR ;sort select
  1.  W ! S DIR(0)="NO^1:"_APCLHIGH_":0",DIR("A")=$S(APCLCTYP="S":"Sub-total ",1:"Sort ")_$S(APCLPTVS="P":"Patients",1:"visits")_" by which of the above" D ^DIR K DIR
  1. SELECTR1 ;
  1.  I $D(DUOUT) W !,"exiting" S APCLQUIT=1 Q
  1.  S APCLANSW=Y
  1.  I APCLANSW="",(APCLCTYP="D"!(APCLCTYP="L")) W !!,"No sort criteria selected ... will sort by "_$S(APCLPTVS="P":"Patient Name",1:"Visit Date")_"." S:APCLPTVS="V" APCLSORT=19,APCLSORV="Visit Date" D  Q
  1.  .S:APCLPTVS="P" APCLSORT=1,APCLSORV="Patient Name"  H 2 D  Q
  1.  ..S DA=APCLRPT,DIE="^APCLVRPT(",DR=".07////"_APCLSORT D ^DIE K DA,DR,DIE,DIU,DIV,DIY,DIW
  1.  I APCLANSW="",APCLCTYP'="D",APCLCTYP'="L" W !!,"No sub-totalling will be done.",!! D  Q
  1.  .S APCLCTYP="T"
  1.  .H 3
  1.  .S:APCLPTVS="V" APCLSORT=19,APCLSORV="Visit Date"
  1.  .S:APCLPTVS="P" APCLSORT=1,APCLSORV="Patient Name"
  1.  S APCLSORT=APCLSEL(+Y),APCLSORV=$P(^APCLVSTS(APCLSORT,0),U),DA=APCLRPT,DIE="^APCLVRPT(",DR=".07////"_APCLSORT D ^DIE K DA,DR,DIE,DIU,DIV,DIY,DIW
  1.  Q
  1. SELECTP ;print select - get columns
  1.  S APCLANS=Y,APCLC="" F APCLI=1:1 S APCLC=$P(APCLANS,",",APCLI) Q:APCLC=""  S APCLCRIT=APCLSEL(APCLC),APCLPCNT=APCLPCNT+1 D
  1.  .I APCLCTYP="D" D
  1.  ..S DIR(0)="N^2:80:0",DIR("A")="Enter Column width for "_$P(^APCLVSTS(APCLCRIT,0),U)_" (suggested: "_$P(^APCLVSTS(APCLCRIT,0),U,7)_")",DIR("B")=$P(^(0),U,7) D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  ..I $D(DIRUT) S Y=$P(^APCLVSTS(APCLCRIT,0),U,7)
  1.  .I APCLCTYP="L" S Y=""
  1.  .S ^APCLVRPT(APCLRPT,12,0)="^9001003.81102PA^1^1"
  1.  .I $D(^APCLVRPT(APCLRPT,12,"B",APCLCRIT)) S X=$O(^APCLVRPT(APCLRPT,12,"B",APCLCRIT,"")),APCLTCW=APCLTCW-$P(^APCLVRPT(APCLRPT,12,X,0),U,2)-2,^APCLVRPT(APCLRPT,12,X,0)=APCLCRIT_U_Y D  Q
  1.  ..Q
  1.  .S ^APCLVRPT(APCLRPT,12,APCLPCNT,0)=APCLCRIT_U_Y,^APCLVRPT(APCLRPT,12,"B",APCLCRIT,APCLPCNT)="",APCLTCW=APCLTCW+Y+2,APCLCSEL(APCLC)=""
  1.  .I APCLCTYP="D" W !!?15,"Total Report width (including column margins - 2 spaces):   ",APCLTCW
  1.  .;new functionality to print 1 or all
  1.  .Q:'$D(^APCLVRPT(APCLRPT,11,"B",APCLCRIT))  ;didn't select this item
  1.  .Q:'$P(^APCLVSTS(APCLCRIT,0),U,13)  ;not one of these items
  1.  .;one or all
  1.  .W !!,"***  This item, ",$P(^APCLVSTS(APCLCRIT,0),U)," was a selection item.  Do you want to print",!,"ALL ",$P(^APCLVSTS(APCLCRIT,0),U),"'s or just those you selected.",!
  1.  .S DIR(0)="S^A:ALL items;O:Only the ones selected",DIR("A")="For this item",DIR("B")="A" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S Y="A"
  1.  .I Y="O" S $P(^APCLVRPT(APCLRPT,12,APCLPCNT,0),U,3)=1
  1.  Q
  1. REM ;EP - remove a selected item - called from protocol entry
  1.  I '$D(APCLCSEL) W !!,"No items have been selected.",! H 2 G REMX
  1.  S DIR(0)="LO^:",DIR("A")="Remove which selected item" K DA D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  ;W ! S DIR(0)="LO^1:"_APCLHIGH,DIR("A")="Remove Which "_$S(APCLPTVS="P":"patient",1:"visit")_" item(s)" D DIRQ^APCLVLS1,^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !,"No items selected." G REMX
  1.  I $D(DIRUT) W !,"No items selected." G REMX
  1.  S APCLANS=Y,APCLC="" F APCLI=1:1 S APCLC=$P(APCLANS,",",APCLI) Q:APCLC=""  D
  1.  .I '$D(APCLSEL(APCLC)) W !,APCLC," is not a valid choice" Q
  1.  .S APCLCRIT=APCLSEL(APCLC) D
  1.  ..I '$D(APCLCSEL(APCLC)) W !,"Item ",APCLC," ",$P(^APCLVSTS(APCLCRIT,0),U)," has not been selected.",! Q
  1.  ..K APCLCSEL(APCLC)
  1.  ..I APCLCNTL="S" K ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
  1.  ..I APCLCNTL="P" S X=$O(^APCLVRPT(APCLRPT,12,"B",APCLCRIT,0)) I X K ^APCLVRPT(APCLRPT,12,X),^APCLVRPT(APCLRPT,12,"B",APCLCRIT)
  1.  ..W !,"Item ",$P(^APCLVSTS(APCLCRIT,0),U)," removed from selected list of items."
  1. REMX ;
  1.  S DIR(0)="EO",DIR("A")="Hit return to continue..." K DA D ^DIR K DIR
  1.  D BACK
  1.  Q
  1. T(Z,Y) ;
  1.  NEW T
  1.  S T=$P(^APCLVSTS(APCLSEL(Z),0),U)
  1.  I $P(^APCLVSTS(APCLSEL(Z),0),U,12)]"",Y="P" S T=$P(^APCLVSTS(APCLSEL(Z),0),U,12)
  1.  Q $E(T,1,22)
  1. Q ;EP - quit selections
  1.  I APCLCNTL="R" S Y="" G SELECTR1
  1.  Q
  1. EXITR ;EP - exit report called from protocol entry
  1.  S APCLQUIT=1
  1.  Q
  1. HELP ; -- help code
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  W !,"Enter an S to Select an Item, and R to remove a selected item, Q to Quit",!,"the selection process.  To exit the report, enter an E.",!,"Hit a Q to select all ",$S(APCLPTVS="V":"visits",1:"patients"),", bypassing all screens.",!
  1.  S X="?" D DISP^XQORM1 W !
  1.  S DIR(0)="EO",DIR("A")="Hit return to continue..." K DA D ^DIR K DIR
  1.  D BACK
  1.  Q
  1.  ;
  1. BACK ;go back to listman
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D INIT
  1.  D HDR
  1.  K DIR
  1.  K X,Y,Z,I
  1.  Q
  1. EXIT ; -- exit code
  1.  K APCLDISP
  1.  K VALMCC,VALMHDR
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;