MCPOS03.m

MCPOS03 ;HIRMFO/DAD-INSTRUMENT FLAT-->MULT CONVERSION FILE #699 ;5/31/96  13:36

 ;;2.3;Medicine;;09/13/1996

 ;

 N D0,DA,DD,DIC,DINUM,DLAYGO,DO,MCARCODE,MCD0,MCDATA,MCINSTR

 S MCDATA(1)=""

 S MCDATA(2)="Moving instrument from flat field into multiple"

 S MCDATA(3)="in the Endoscopy/Consult file (#699)."

 D MES^XPDUTL(.MCDATA)

 ;

 S MCD0=0

 F  S MCD0=$O(^MCAR(699,MCD0)) Q:MCD0'>0  D

 . S MCINSTR=+$P($G(^MCAR(699,MCD0,0)),U,7)

 . I MCINSTR'>0 Q

 . S $P(^MCAR(699,MCD0,0),U,7)=""

 . I $O(^MCAR(699,MCD0,34,"B",MCINSTR,0)) Q

 . S MCINSTR(0)=$G(^MCAR(699.48,MCINSTR,0))

 . I $P(MCINSTR(0),U)="" Q

 . K DD,DIC,DINUM,DO

 . S DIC="^MCAR(699,"_MCD0_",34,",DIC(0)="M",DLAYGO=699

 . S DIC("P")=$$GET1^DID(699,4,"","SPECIFIER")

 . S (D0,DA(1))=MCD0,X=MCINSTR,MCARCODE=$P(MCINSTR(0),U,2)

 . D FILE^DICN

 . Q

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---MCPOS03   825     printed  Apr 09, 2024@21:19:49                                                                                                                                                                                                      Page 2

MCPOS03   ;HIRMFO/DAD-INSTRUMENT FLAT-->MULT CONVERSION FILE #699 ;5/31/96  13:36

 +1       ;;2.3;Medicine;;09/13/1996

 +2       ;

 +3        NEW D0,DA,DD,DIC,DINUM,DLAYGO,DO,MCARCODE,MCD0,MCDATA,MCINSTR

 +4        SET MCDATA(1)=""

 +5        SET MCDATA(2)="Moving instrument from flat field into multiple"

 +6        SET MCDATA(3)="in the Endoscopy/Consult file (#699)."

 +7        DO MES^XPDUTL(.MCDATA)

 +8       ;

 +9        SET MCD0=0

 +10       FOR 

               SET MCD0=$ORDER(^MCAR(699,MCD0))

               if MCD0'>0

                   QUIT 

               Begin DoDot:1

 +11               SET MCINSTR=+$PIECE($GET(^MCAR(699,MCD0,0)),U,7)

 +12               IF MCINSTR'>0

                       QUIT 

 +13               SET $PIECE(^MCAR(699,MCD0,0),U,7)=""

 +14               IF $ORDER(^MCAR(699,MCD0,34,"B",MCINSTR,0))

                       QUIT 

 +15               SET MCINSTR(0)=$GET(^MCAR(699.48,MCINSTR,0))

 +16               IF $PIECE(MCINSTR(0),U)=""

                       QUIT 

 +17               KILL DD,DIC,DINUM,DO

 +18               SET DIC="^MCAR(699,"_MCD0_",34,"

                   SET DIC(0)="M"

                   SET DLAYGO=699

 +19               SET DIC("P")=$$GET1^DID(699,4,"","SPECIFIER")

 +20               SET (D0,DA(1))=MCD0

                   SET X=MCINSTR

                   SET MCARCODE=$PIECE(MCINSTR(0),U,2)

 +21               DO FILE^DICN

 +22               QUIT 

               End DoDot:1

 +23       QUIT