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

APCLVL5.m

Go to the documentation of this file. 
  1. APCLVL5 ; 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.  K APCLCSEL
  1.  I APCLCNTL="R" S (APCLSORV,APCLSORT)=""
  1.  D EN^VALM("APCL GEN GROUP SELECTION")
  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 items in any of the groups listed."
  1.  S VALMHDR(3)="When you select a group a different screen will be displayed with the list of"
  1.  S VALMHDR(4)="items in that group for your selection.  To bypass screens type 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)="Items from the following groups can be selected for printing.  Choose the"
  1.  S VALMHDR(3)="the group from which you want an item to print. 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)="                        "_$G(IORVON)_"SORT ITEM SELECTION MENU"_$G(IORVOFF)
  1.  S VALMHDR(2)="The "_$S(APCLPTVS="P":"patients",1:"visits")_" displayed can be SORTED by ONLY ONE item."
  1.  S VALMHDR(3)="If you don't select a sort item, the report will be sorted by "_$S(APCLPTVS="V":"visit date.",1:"patient name.")
  1.  S VALMHDR(4)="Choose the group from which the sort item will be selected."
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  K APCLGRP
  1.  S C=0,APCLITEM=0
  1.  I $D(APCLCSEL) D
  1.  .S N=$S(APCLCNTL="S":11,1:12)
  1.  .S C=C+1,$E(APCLGRP(C,0),2)="Selected: "
  1.  .S Z=0 F  S Z=$O(^APCLVRPT(APCLRPT,N,Z)) Q:Z'=+Z  S:$L(APCLGRP(C,0))>60 C=C+1 S:'$D(APCLGRP(C,0)) $E(APCLGRP(C,0),4)=" " S APCLGRP(C,0)=$G(APCLGRP(C,0))_$P(^APCLVSTS($P(^APCLVRPT(APCLRPT,N,Z,0),U),0),U)_"; "
  1.  S X=0 F  S X=$O(^APCLGENG("O",X)) Q:X'=+X  S Y=0 F  S Y=$O(^APCLGENG("O",X,Y)) Q:Y'=+Y  D
  1.  .Q:$P(^APCLGENG(Y,0),U,3)'[APCLPTVS
  1.  .S C=C+1,APCLITEM=APCLITEM+1
  1.  .S APCLGRP(C,0)=APCLITEM_".  "_$P(^APCLGENG(Y,0),U),APCLGRP("IDX",APCLITEM,APCLITEM)=Y
  1.  .;I $D(APCLCSEL),$D(APCLCSEL("GRP",Y)) D
  1.  .;.S C=C+1,$E(APCLGRP(C,0),5)="Selected: " S Z=0 F  S Z=$O(APCLCSEL(Z)) Q:Z'=+Z  S:$L(APCLGRP(C,0))>60 C=C+1 S:'$D(APCLGRP(C,0)) $E(APCLGRP(C,0),4)=" " S APCLGRP(C,0)=$G(APCLGRP(C,0))_$P(^APCLVSTS(Z,0),U)_"; "
  1.  .I APCLCNTL="R",APCLSORT]"",APCLSORG=Y S C=C+1,APCLGRP(C,0)="     Sort item selected: "_$P(^APCLVSTS(APCLSORT,0),U)  ;write out items already selected
  1.  S VALMCNT=C
  1.  Q
  1.  ;
  1. ADD ;EP - add an item to the selected list - called from a protocol
  1.  D FULL^VALM1
  1.  I APCLCNTL="R",APCLSORT]"" D
  1.  .W !!,"You have already selected a sort item and you can only select one.  If you"
  1.  .W !,"want to keep the sort item you selected then just type '^' a the select group"
  1.  .W !,"prompt, otherwise continue on to select a group and select a differnt sort"
  1.  .W !,"item.",!
  1.  S APCLGIEN=0
  1.  W ! S DIR(0)="NO^1:"_APCLITEM_":0",DIR("A")="Which Group" D ^DIR K DIR
  1.  I $D(DIRUT) D BACK Q
  1.  S APCLP=Y I 'APCLP K APCLP,VALMY,XQORNOD,APCLGIEN W !,"No Group selected." Q
  1.  S (X,Y)=0 F  S X=$O(APCLGRP("IDX",X)) Q:X'=+X!(APCLGIEN)  I $O(APCLGRP("IDX",X,0))=APCLP S Y=$O(APCLGRP("IDX",X,0)),APCLGIEN=APCLGRP("IDX",X,Y)
  1.  I '$D(^APCLGENG(APCLGIEN,0)) W !,"Not a valid GROUP." K APCLP S APCLGIEN=0 Q
  1.  ;D FULL^VALM1 ;give me full control of screen
  1.  ;I now have group so go to listman to display all items in that group
  1.  D ^APCLVL6
  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 T
  1. Q ;EP - quit selections
  1.  I APCLCNTL="R",APCLSORT="" 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.  ;